module Canteven.HTTP (
FromEntity(..),
ToEntity(..),
DecodeResult(..),
ContentType,
requestLogging,
logExceptionsAndContinue,
setServer,
staticSite,
) where
import Canteven.Internal (staticSite)
import Canteven.Log.MonadLog (LoggerTImpl)
import Control.Concurrent (threadDelay)
import Control.Exception (SomeException)
import Control.Monad (void)
import Control.Monad.Catch (try, throwM)
import Control.Monad.Logger (runLoggingT, LoggingT, logInfo, logError)
import Control.Monad.Trans.Class (lift)
import Data.ByteString (ByteString)
import Data.List (find)
import Data.Monoid ((<>))
import Data.Text (Text, pack)
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 Network.HTTP.Types (internalServerError500, Status, statusCode, statusMessage)
import Network.Wai (Middleware, responseStatus, requestMethod, rawPathInfo,
rawQueryString, Response, ResponseReceived, requestHeaders, responseLBS, modifyResponse)
import Network.Wai.Middleware.AddHeaders (addHeaders)
import Network.Wai.Middleware.StripHeaders (stripHeader)
import qualified Data.ByteString.Lazy as BSL
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) $ requestStartMessage requestHeaderRequestId <> 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)
$ reqStr <> " --> " <> showStatus (responseStatus response)
<> " (" <> (pack . show $ diffUTCTime now start) <> ")"
return ack
reqStr :: Text
reqStr = decodeUtf8
$ requestMethod req <> " " <> rawPathInfo req <> rawQueryString req
showStatus :: Status -> Text
showStatus stat =
(pack . show . statusCode) stat <> " "
<> (decodeUtf8 . statusMessage) stat
requestHeaderRequestId :: Maybe ByteString
requestHeaderRequestId = snd <$> find ((==) "X-Request-Id" . fst)
(requestHeaders req)
requestStartMessage :: Maybe ByteString -> Text
requestStartMessage Nothing =
"Starting request without requestId: "
requestStartMessage (Just requestId) =
"Starting request with requestId " <> decodeUtf8 requestId <> ": "
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))