diff options
| -rw-r--r-- | Cana.cabal | 13 | ||||
| -rw-r--r-- | app/Main.hs | 3 | ||||
| -rw-r--r-- | src/Cana/Extra.hs | 91 |
3 files changed, 106 insertions, 1 deletions
@@ -26,6 +26,7 @@ source-repository head library exposed-modules: Cana + Cana.Extra Cana.Monad Cana.Protocol Cana.Router @@ -39,8 +40,12 @@ library base >=4.7 && <5 , bytestring , data-default + , directory + , filepath + , mime-types , network , network-uri + , text , tls , transformers , x509 @@ -59,8 +64,12 @@ executable Cana-exe , base >=4.7 && <5 , bytestring , data-default + , directory + , filepath + , mime-types , network , network-uri + , text , tls , transformers , x509 @@ -80,8 +89,12 @@ test-suite Cana-test , base >=4.7 && <5 , bytestring , data-default + , directory + , filepath + , mime-types , network , network-uri + , text , tls , transformers , x509 diff --git a/app/Main.hs b/app/Main.hs index 000726d..50ca151 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,6 +4,7 @@ module Main where import Cana import Cana.Protocol import Cana.Router +import Cana.Extra defaultResponse :: GeminiResponse defaultResponse = GeminiResponse @@ -14,5 +15,5 @@ defaultResponse = GeminiResponse main :: IO () main = runGeminiServer Nothing defaultGeminiPort "certificate.crt" "private.key" - [ (anyRoute, const $ return defaultResponse) + [ (anyRoute, staticFiles "gmdocs") ] diff --git a/src/Cana/Extra.hs b/src/Cana/Extra.hs new file mode 100644 index 0000000..c776160 --- /dev/null +++ b/src/Cana/Extra.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Cana.Extra +-- +-- This module contains some extra goodies for writing a Gemini server with +-- "Cana", for exmaple a static file server. + +module Cana.Extra + ( -- * High-Level handlers + staticFiles + ) where + +import Cana.Types +import Cana.Protocol + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.Maybe + +import Data.String +import Data.Maybe +import qualified Data.Text as T +import System.FilePath +import System.Directory +import Control.Monad.IO.Class +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Lazy.Char8 (pack) +import Network.URI +import Network.Mime + + +-- | Default name for the directory index file. +defaultIndexFile :: String +defaultIndexFile = "index.gmi" + +-- | The Gemini MIME type. +geminiMime :: IsString a => a +geminiMime = "text/gemini" + +-- | A static file handler. +-- +-- This handler takes a file path and looks up any request in the given +-- directory. +staticFiles :: FilePath -- ^ Base directory where static files are searched. + -> Handler +staticFiles basedir request = do + let reqPath = sanitize . uriPath . requestUri $ request + fsPath = basedir ++ reqPath + notFoundResponse = GeminiResponse + { responseStatus = codeNotFound + , responseMeta = "Those are not the capsules you are looking for" + , responseData = "" + } + + dirIndex <- liftIO $ readDirIndex fsPath + fileContent <- liftIO $ readFileContent fsPath + return $ fromMaybe notFoundResponse (dirIndex <|> fileContent) + where + sanitize :: FilePath -> FilePath + sanitize = joinPath + . filter (\p -> dropTrailingPathSeparator p /= "..") + . splitPath + . normalise + + readDirIndex :: FilePath -> IO (Maybe GeminiResponse) + readDirIndex path = runMaybeT $ do + guard $ hasTrailingPathSeparator path + liftIO (doesDirectoryExist path) >>= guard + liftIO (doesFileExist $ path </> defaultIndexFile) >>= guard + content <- liftIO $ BSL.readFile (path </> defaultIndexFile) + return GeminiResponse + { responseStatus = codeSuccess + , responseMeta = geminiMime + , responseData = content + } + + readFileContent :: FilePath -> IO (Maybe GeminiResponse) + readFileContent path = runMaybeT $ do + liftIO (doesFileExist path) >>= guard + content <- liftIO $ BSL.readFile path + return GeminiResponse + { responseStatus = codeSuccess + , responseMeta = getMime path + , responseData = content + } + + getMime :: FilePath -> BSL.ByteString + getMime path + | takeExtension path == ".gmi" = geminiMime + | otherwise = BSL.fromStrict + . defaultMimeLookup . T.pack $ takeFileName path |