139 lines
4.3 KiB
Haskell
139 lines
4.3 KiB
Haskell
module Gemini where
|
|
|
|
import Control.Exception
|
|
import Data.ByteString.UTF8
|
|
import Data.Text
|
|
import Network.Mime
|
|
import Network.URI
|
|
import System.Directory (doesDirectoryExist, doesFileExist)
|
|
import Text.Regex
|
|
import Text.Regex.PCRE
|
|
|
|
getFile :: FilePath -> IO (Maybe String)
|
|
getFile s = do
|
|
exists <- doesFileExist s
|
|
case exists of
|
|
True -> do
|
|
result <- try (readFile s) :: IO (Either SomeException String)
|
|
case result of
|
|
Left ex -> return Nothing
|
|
Right ex -> return (Just ex)
|
|
False -> return Nothing
|
|
|
|
-- remove any .. in the uri that could escape the location
|
|
sanitize_uri :: String -> String
|
|
sanitize_uri path =
|
|
subRegex (mkRegex "\\.\\.\\/") path ""
|
|
|
|
remove_crnlf :: String -> String
|
|
remove_crnlf uri =
|
|
subRegex (mkRegex "\r\n$") uri ""
|
|
|
|
-- 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 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"
|
|
| (fileNameExtensions (pack filename)) == [(pack "md" :: Extension)] = "text/markdown"
|
|
| otherwise = (toString (defaultMimeLookup (pack filename)))
|
|
|
|
geminiInvalidURI :: Answer
|
|
geminiInvalidURI =
|
|
MkAnswer
|
|
{ code = 50,
|
|
lang = "",
|
|
mime = "",
|
|
content = ""
|
|
}
|
|
|
|
create_answer :: String -> String -> String -> Bool -> IO Answer
|
|
create_answer request language baseDir vhost = do
|
|
-- parse the URI
|
|
case parseURI (remove_crnlf (sanitize_uri request)) of
|
|
Nothing -> return geminiInvalidURI
|
|
Just uri -> do
|
|
-- look for authority info
|
|
case uriAuthority uri of
|
|
Nothing -> pure geminiInvalidURI
|
|
-- request is valid from here
|
|
Just auth -> do
|
|
let domain = uriRegName auth
|
|
let file = uriPath uri
|
|
let baseDir' =
|
|
if vhost
|
|
then baseDir ++ "/" ++ domain
|
|
else baseDir
|
|
content <- getFile $ baseDir' ++ file
|
|
case content of
|
|
-- file has been found
|
|
Just x ->
|
|
return
|
|
( MkAnswer
|
|
{ code = 20,
|
|
lang = language,
|
|
mime = get_mime file,
|
|
content = x
|
|
}
|
|
)
|
|
Nothing -> do
|
|
-- no file
|
|
-- try /index.gmi
|
|
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 = 52,
|
|
lang = language,
|
|
mime = "",
|
|
content = "can't find " ++ baseDir' ++ file
|
|
}
|
|
)
|
|
|
|
make_reply :: Answer -> String
|
|
make_reply (MkAnswer code lang content mime)
|
|
| code == 20 && mime == "text/gemini" && lang /= "" = "20 " ++ mime ++ "; lang=" ++ lang ++ " \r\n"
|
|
| code == 20 && mime == "text/gemini" && lang == "" = "20 " ++ mime ++ "; \r\n"
|
|
| code == 20 && mime /= "text/gemini" = "20 " ++ mime ++ "\r\n"
|
|
| code == 31 = "31 " ++ mime ++ "\r\n"
|
|
| otherwise = "55\r\n"
|