diff --git a/.src/Canteven/Internal.hs b/.src/Canteven/Internal.hs new file mode 100644 --- /dev/null +++ b/.src/Canteven/Internal.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +module Canteven.Internal ( + staticSite +) where + +import Control.Monad (join) +import Data.List ((\\)) +import Data.Maybe (catMaybes) +import Language.Haskell.TH (TExp, Q, runIO) +import Language.Haskell.TH.Syntax (addDependentFile) +import Network.HTTP.Types (ok200) +import Network.Mime (defaultMimeLookup) +import Network.Wai (Middleware, responseLBS, pathInfo) +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.Char8 as BSL8 +import qualified Data.Text as T + +{- | + The Template-Haskell splice @$$(staticSite dir)@ will build a + 'Middleware' that serves a set of static files determined at + compile time, or else passes the request to the underlying + 'Network.Wai.Application'. + + All files under @dir@ will be served relative to the root path of + your web server, so the file @\\/foo\/bar.html@ will be served at + @http://your-web-site.com/foo/bar.html@ + + @since 0.1.3 +-} +staticSite :: FilePath -> Q (TExp Middleware) +staticSite baseDir = join . runIO $ do + files <- readStaticFiles + mapM_ (printResource . fst) files + return $ mapM_ (addDependentFile . ((baseDir ++ "/") ++) . fst) files >> [|| + let + {- | + Build a middleware that serves a single static file path, or + delegates to the underlying application. + -} + static :: (FilePath, String) -> Middleware + static (filename, content) app req respond = + let + {- | Guess the content type of the static file. -} + contentType :: BS.ByteString + contentType = + defaultMimeLookup + . T.pack + $ filename + in + if pathInfo req == T.split (== '/') (T.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) + + {- | Reads the static files that make up the admin user interface. -} + 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) diff --git a/canteven-http.cabal b/canteven-http.cabal --- a/canteven-http.cabal +++ b/canteven-http.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: canteven-http -version: 0.1.4.0 +version: 0.1.5.1 synopsis: Utilities for HTTP programming. -- description: homepage: https://github.com/SumAll/canteven-http @@ -19,7 +19,8 @@ library exposed-modules: Canteven.HTTP - -- other-modules: + other-modules: + Canteven.Internal -- other-extensions: build-depends: base >= 4.7 && < 4.10, @@ -39,6 +40,8 @@ uuid >= 1.3.12 && < 1.4, wai >= 3.2 && < 3.3, wai-extra >= 3.0.8 && < 3.1 - hs-source-dirs: src + hs-source-dirs: + src + .src default-language: Haskell2010 ghc-options: -Wall diff --git a/src/Canteven/HTTP.hs b/src/Canteven/HTTP.hs --- a/src/Canteven/HTTP.hs +++ b/src/Canteven/HTTP.hs @@ -16,40 +16,29 @@ staticSite, ) where - +import Canteven.Internal (staticSite) import Canteven.Log.MonadLog (LoggerTImpl) import Control.Concurrent (threadDelay) import Control.Exception (SomeException) -import Control.Monad (void, join) +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.List ((\\)) -import Data.Maybe (catMaybes) +import Data.ByteString (ByteString) +import Data.List (find) import Data.Monoid ((<>)) -import Data.Text (Text, pack, unpack) +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 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.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 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 {- | The class of things that can be read as http message entities. -} @@ -148,8 +137,7 @@ -} requestLogging :: LoggerTImpl -> Middleware requestLogging logging app req respond = (`runLoggingT` logging) $ do - $(logInfo) . pack - $ "Starting request: " ++ reqStr + $(logInfo) $ requestStartMessage requestHeaderRequestId <> reqStr lift . app req . loggingRespond =<< lift getCurrentTime where {- | Delegate to the underlying responder, and do some logging. -} @@ -161,26 +149,36 @@ -} ack <- lift $ respond response now <- lift getCurrentTime - $(logInfo) . pack - $ reqStr ++ " --> " ++ showStatus (responseStatus response) - ++ " (" ++ show (diffUTCTime now start) ++ ")" + $(logInfo) + $ reqStr <> " --> " <> showStatus (responseStatus response) + <> " (" <> (pack . show $ diffUTCTime now start) <> ")" return ack - {- | A string representation of the request, suitable for logging. -} - reqStr :: String - reqStr = unpack . decodeUtf8 + {- | A Text representation of the request, suitable for logging. -} + reqStr :: Text + reqStr = decodeUtf8 $ requestMethod req <> " " <> rawPathInfo req <> rawQueryString req {- | @instance Show Status@ shows the Haskell structure, which is not suitable for logging. -} - showStatus :: Status -> String + showStatus :: Status -> Text showStatus stat = - show (statusCode stat) ++ " " - ++ (unpack . decodeUtf8 . statusMessage) 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 <> ": " + + {- | Set the @Server:@ header. @@ -199,85 +197,3 @@ {- | The value of the @Server:@ header. -} serverValue = encodeUtf8 (serviceName <> "/" <> pack (showVersion version)) - - -{- | - The Template-Haskell splice @$$(staticSite dir)@ will build a - 'Middleware' that serves a set of static files determined at - compile time, or else passes the request to the underlying - 'Network.Wai.Application'. - - All files under @dir@ will be served relative to the root path of - your web server, so the file @\\/foo\/bar.html@ will be served at - @http://your-web-site.com/foo/bar.html@ - - @since 0.1.3 --} -staticSite :: FilePath -> Q (TExp Middleware) -staticSite baseDir = join . runIO $ do - files <- readStaticFiles - mapM_ (printResource . fst) files - return $ [|| - let - {- | - Build a middleware that serves a single static file path, or - delegates to the underlying application. - -} - static :: (FilePath, String) -> Middleware - static (filename, content) app req respond = - let - {- | Guess the content type of the static file. -} - 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) - - {- | Reads the static files that make up the admin user interface. -} - 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) -