apply ormolu for formatting

src/Gemini.hs

@@ -0,0 +1,121 @@
+module Gemini where
+
+import Control.Exception
+import Data.ByteString.UTF8
+import Data.Text
+import Network.Mime
+import System.Directory (doesDirectoryExist, doesFileExist)
+import Text.Regex
+import Text.Regex.PCRE
+
+
+getFile :: FilePath -> IO (Maybe String)
+getFile s = do
+  result <- try (readFile s) :: IO (Either SomeException String)
+  case result of
+    Left ex -> return Nothing
+    Right ex -> return (pure ex)
+
+-- return components of the url
+-- gemini:// | hostname | uri | ? | query
+parse_url :: String -> [[String]]
+parse_url url =
+  (sanitize_uri url) =~ "^(gemini:\\/\\/)([^\\/]*)\\/?([^\\?]*)(\\?)?(.*)?(\\r\\n)$"
+
+-- remove any .. in the uri that could escape the location
+sanitize_uri :: String -> String
+sanitize_uri path =
+  subRegex (mkRegex "\\.\\.\\/") path ""
+
+-- return a file as a string
+read_file :: String -> IO String
+read_file path = do
+  text <- readFile path
+  pure text
+
+-- read from stdin
+get_request :: IO String
+get_request = do
+  stdin <- getContents
+  pure stdin
+
+data Gemini = MkGemini
+  { domain :: String,
+    file :: String,
+    query :: String
+  }
+
+data Answer = MkAnswer
+  { code :: Int,
+    lang :: String,
+    content :: String,
+    mime :: String
+  }
+
+get_mime :: String -> String
+get_mime filename
+  | (fileNameExtensions (pack filename)) == [(pack "gmi" :: Extension)] = "text/gemini"
+  | (fileNameExtensions (pack filename)) == [(pack "gemini" :: Extension)] = "text/gemini"
+  | otherwise = (toString (defaultMimeLookup (pack filename)))
+
+parse_to_gemini :: [[String]] -> Gemini
+parse_to_gemini tab =
+  MkGemini
+    { domain = tab !! 0 !! 2,
+      file = tab !! 0 !! 3,
+      query = tab !! 0 !! 5
+    }
+
+create_answer :: Gemini -> String -> String -> IO Answer
+create_answer (MkGemini domain file query) language basedir = do
+  content <- getFile $ basedir ++ file
+  case content of
+    Just x ->
+      return
+        ( MkAnswer
+            { code = 20,
+              lang = language,
+              mime = get_mime file,
+              content = x
+            }
+        )
+    Nothing -> do
+      content' <- getFile $ baseDir' ++ file ++ "index.gmi"
+      case content' of
+        Just y ->
+          return
+            ( MkAnswer
+                { code = 20,
+                  lang = language,
+                  mime = get_mime $ file ++ "index.gmi",
+                  content = y
+                }
+            )
+        Nothing -> do
+          isdir <- doesDirectoryExist $ baseDir' ++ file
+          if isdir
+            then
+              return
+                ( MkAnswer
+                    { code = 31,
+                      lang = "",
+                      mime = "/" ++ file ++ "/",
+                      content = ""
+                    }
+                )
+            else
+              return
+                ( MkAnswer
+                    { code = 50,
+                      lang = language,
+                      mime = "",
+                      content = "error ici " ++ baseDir' ++ file ++ "/index.gmi"
+                    }
+                )
+
+make_reply :: Answer -> String
+make_reply (MkAnswer code lang content mime)
+  | lang /= "" = (show code) ++ " " ++ mime ++ "; lang=" ++ lang ++ " \r\n"
+  | code == 20 && lang == "" = (show code) ++ " " ++ mime ++ "; \r\n"
+  | code == 31 = "31 " ++ mime ++ "\r\n"
+  | otherwise = "50\r\n"

src/Vger.hs

@@ -1,33 +1,42 @@
+{-# Language ApplicativeDo #-}
+{-# Language RecordWildCards #-}
 import Gemini
 import Options.Applicative
 
+
 data Sample = Sample
   { baseDir :: String
   , language  :: String
+  , virtualhost :: Bool
   }
 
 sample :: Parser Sample
-sample = Sample
-      <$> strOption
+sample = do
+       baseDir <- strOption
           ( long "baseDir"
          <> short 'd'
          <> help "base directory to serve files from"
          <> value "/var/gemini/")
-      <*> strOption
+       language <- strOption
           ( long "language"
          <> short 'l'
          <> help "language to use in the response for gemini files"
          <> value "")
+       virtualhost <- switch
+          ( long "virtualhost"
+         <> short 'v'
+         <> help "virtualhost support")
+       pure Sample{..}
 
 opts :: ParserInfo Sample
 opts = info (sample <**> helper)
-  ( fullDesc)
+  (fullDesc)
 
 main :: IO ()
 main = do
     options <- execParser opts
     url <- get_request
     let request = parse_to_gemini (parse_url url)
-    answer <- create_answer request (language options) (baseDir options)
+    answer <- create_answer request (language options) (baseDir options) (virtualhost options)
     putStr (make_reply answer)
     putStr (content answer)