apply ormolu for formatting
This commit is contained in:
parent
32bee65a20
commit
95a2ef910e
|
@ -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"
|
|
@ -1,33 +1,42 @@
|
||||||
|
{-# Language ApplicativeDo #-}
|
||||||
|
{-# Language RecordWildCards #-}
|
||||||
import Gemini
|
import Gemini
|
||||||
import Options.Applicative
|
import Options.Applicative
|
||||||
|
|
||||||
|
|
||||||
data Sample = Sample
|
data Sample = Sample
|
||||||
{ baseDir :: String
|
{ baseDir :: String
|
||||||
, language :: String
|
, language :: String
|
||||||
|
, virtualhost :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
sample :: Parser Sample
|
sample :: Parser Sample
|
||||||
sample = Sample
|
sample = do
|
||||||
<$> strOption
|
baseDir <- strOption
|
||||||
( long "baseDir"
|
( long "baseDir"
|
||||||
<> short 'd'
|
<> short 'd'
|
||||||
<> help "base directory to serve files from"
|
<> help "base directory to serve files from"
|
||||||
<> value "/var/gemini/")
|
<> value "/var/gemini/")
|
||||||
<*> strOption
|
language <- strOption
|
||||||
( long "language"
|
( long "language"
|
||||||
<> short 'l'
|
<> short 'l'
|
||||||
<> help "language to use in the response for gemini files"
|
<> help "language to use in the response for gemini files"
|
||||||
<> value "")
|
<> value "")
|
||||||
|
virtualhost <- switch
|
||||||
|
( long "virtualhost"
|
||||||
|
<> short 'v'
|
||||||
|
<> help "virtualhost support")
|
||||||
|
pure Sample{..}
|
||||||
|
|
||||||
opts :: ParserInfo Sample
|
opts :: ParserInfo Sample
|
||||||
opts = info (sample <**> helper)
|
opts = info (sample <**> helper)
|
||||||
( fullDesc)
|
(fullDesc)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
options <- execParser opts
|
options <- execParser opts
|
||||||
url <- get_request
|
url <- get_request
|
||||||
let request = parse_to_gemini (parse_url url)
|
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 (make_reply answer)
|
||||||
putStr (content answer)
|
putStr (content answer)
|
Loading…
Reference in New Issue