{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Canteven.HTTP (
FromEntity(..),
ToEntity(..),
DecodeResult(..),
ContentType,
requestLogging,
logExceptionsAndContinue,
setServer,
staticSite,
) where
import Canteven.Log.MonadLog (LoggerTImpl)
import Control.Concurrent (threadDelay)
import Control.Exception (SomeException)
import Control.Monad (void, join)
import Control.Monad.Catch (try, throwM)
import Control.Monad.Logger (runLoggingT, LoggingT, logInfo, logError)
import Control.Monad.Trans.Class (lift)
import Data.List ((\\))
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Time.Clock (getCurrentTime, UTCTime, diffUTCTime)
import Data.UUID (UUID)
import Data.UUID.V1 (nextUUID)
import Data.Version (showVersion, Version)
import Language.Haskell.TH (TExp, Q, runIO)
import Network.HTTP.Types (internalServerError500, Status, statusCode,
statusMessage, ok200)
import Network.Mime (defaultMimeLookup)
import Network.Wai (Middleware, responseStatus, requestMethod,
rawPathInfo, rawQueryString, Response, ResponseReceived, responseLBS,
modifyResponse, pathInfo)
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.StripHeaders (stripHeader)
import System.Directory (getDirectoryContents)
import System.FilePath.Posix (combine, (</>))
import System.Posix.Files (isRegularFile, isDirectory, getFileStatus)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSL8
import qualified Data.Text as T
class FromEntity e where
decodeEntity :: Maybe ContentType -> BSL.ByteString -> DecodeResult e
class ToEntity e where
getContentType :: e -> ContentType
getBytes :: e -> BSL.ByteString
data DecodeResult e
= Unsupported
| BadEntity String
| Ok e
deriving (Show)
type ContentType = BSL.ByteString
logExceptionsAndContinue :: LoggerTImpl -> Middleware
logExceptionsAndContinue logging app req respond = (`runLoggingT` logging) $
try (lift (app req loggingRespond)) >>= \case
Right ack -> return ack
Left err -> do
uuid <- logProblem err
lift $ respond (errResponse uuid)
where
errResponse :: UUID -> Response
errResponse uuid =
responseLBS
internalServerError500
[("Content-Type", "text/plain")]
(BSL.fromStrict . encodeUtf8 . pack
$ "Internal Server Error. Error ID: " ++ show uuid)
getUUID :: LoggingT IO UUID
getUUID = lift nextUUID >>= \case
Nothing -> lift (threadDelay 1000) >> getUUID
Just uuid -> return uuid
loggingRespond :: Response -> IO ResponseReceived
loggingRespond response = (`runLoggingT` logging) $
try (lift (respond response)) >>= \case
Right ack -> return ack
Left err -> do
void $ logProblem err
throwM err
logProblem :: SomeException -> LoggingT IO UUID
logProblem err = do
uuid <- getUUID
$(logError) . pack
$ "Internal Server Error [" ++ show uuid ++ "]: "
++ show (err :: SomeException)
return uuid
requestLogging :: LoggerTImpl -> Middleware
requestLogging logging app req respond = (`runLoggingT` logging) $ do
$(logInfo) . pack
$ "Starting request: " ++ reqStr
lift . app req . loggingRespond =<< lift getCurrentTime
where
loggingRespond :: UTCTime -> Response -> IO ResponseReceived
loggingRespond start response = (`runLoggingT` logging) $ do
ack <- lift $ respond response
now <- lift getCurrentTime
$(logInfo) . pack
$ reqStr ++ " --> " ++ showStatus (responseStatus response)
++ " (" ++ show (diffUTCTime now start) ++ ")"
return ack
reqStr :: String
reqStr = unpack . decodeUtf8
$ requestMethod req <> " " <> rawPathInfo req <> rawQueryString req
showStatus :: Status -> String
showStatus stat =
show (statusCode stat) ++ " "
++ (unpack . decodeUtf8 . statusMessage) stat
setServer :: Text -> Version -> Middleware
setServer serviceName version = addServerHeader . stripServerHeader
where
stripServerHeader :: Middleware
stripServerHeader = modifyResponse (stripHeader "Server")
addServerHeader :: Middleware
addServerHeader = addHeaders [("Server", serverValue)]
serverValue = encodeUtf8 (serviceName <> "/" <> pack (showVersion version))
staticSite :: FilePath -> Q (TExp Middleware)
staticSite baseDir = join . runIO $ do
files <- readStaticFiles
mapM_ (printResource . fst) files
return $ [||
let
static :: (FilePath, String) -> Middleware
static (filename, content) app req respond =
let
contentType :: BS.ByteString
contentType =
defaultMimeLookup
. pack
$ filename
in
if pathInfo req == T.split (== '/') (pack filename)
then
respond (
responseLBS
ok200
[("content-type", contentType)]
(BSL8.pack content)
)
else app req respond
in
foldr (.) id (fmap static files) :: Middleware
||]
where
printResource :: String -> IO ()
printResource file =
putStrLn ("Generating static resource for: " ++ show file)
readStaticFiles :: IO [(FilePath, String)]
readStaticFiles =
let
findAll :: FilePath -> IO [FilePath]
findAll dir = do
contents <-
(\\ [".", ".."]) <$> getDirectoryContents (baseDir </> dir)
dirs <- catMaybes <$> mapM justDir contents
files <- catMaybes <$> mapM justFile contents
more <- concat <$> mapM (findAll . combine dir) dirs
return $ (combine dir <$> files) ++ more
where
justFile :: FilePath -> IO (Maybe FilePath)
justFile filename = do
isfile <-
isRegularFile <$>
getFileStatus (baseDir </> dir </> filename)
return $ if isfile then Just filename else Nothing
justDir :: FilePath -> IO (Maybe FilePath)
justDir filename = do
isdir <-
isDirectory <$>
getFileStatus (baseDir </> dir </> filename)
return $ if isdir then Just filename else Nothing
in do
allFiles <- findAll "."
allContent <- mapM (fmap BS8.unpack . BS.readFile . combine baseDir) allFiles
return (zip (drop 2 <$> allFiles) allContent)