canteven-http 0.1.4.0 → 0.1.5.1
raw patch · 3 files changed
+136/−115 lines, 3 files
Files
- .src/Canteven/Internal.hs +102/−0
- canteven-http.cabal +6/−3
- src/Canteven/HTTP.hs +28/−112
+ .src/Canteven/Internal.hs view
@@ -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 @\<dir\>\/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)
canteven-http.cabal view
@@ -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
src/Canteven/HTTP.hs view
@@ -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 @\<dir\>\/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)-