diff --git a/src/Gemini.hs b/src/Gemini.hs new file mode 100644 index 0000000..51ffcf0 --- /dev/null +++ b/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" diff --git a/Unit.hs b/src/Unit.hs similarity index 100% rename from Unit.hs rename to src/Unit.hs diff --git a/Vger.hs b/src/Vger.hs similarity index 67% rename from Vger.hs rename to src/Vger.hs index 614510b..4875cb2 100644 --- a/Vger.hs +++ b/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)