canteven-http 0.1.2.0 → 0.1.3.0
raw patch · 2 files changed
+118/−21 lines, 2 filesdep +directorydep +filepathdep +mime-types
Dependencies added: directory, filepath, mime-types, template-haskell, unix
Files
- canteven-http.cabal +18/−13
- src/Canteven/HTTP.hs +100/−8
canteven-http.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: canteven-http-version: 0.1.2.0+version: 0.1.3.0 synopsis: Utilities for HTTP programming. -- description: homepage: https://github.com/SumAll/canteven-http@@ -22,18 +22,23 @@ -- other-modules: -- other-extensions: build-depends:- base >= 4.7 && < 4.10,- bytestring >= 0.10 && < 0.11,- canteven-log >= 1.0 && < 2.1,- exceptions >= 0.8.2 && < 0.9,- http-types >= 0.9.1 && < 0.10,- monad-logger >= 0.3.19 && < 0.4,- text >= 1.2 && < 1.3,- time >= 1.5.0.1 && < 1.7,- transformers >= 0.4.2.0 && < 0.6,- uuid >= 1.3.12 && < 1.4,- wai >= 3.2 && < 3.3,- wai-extra >= 3.0.8 && < 3.1+ base >= 4.7 && < 4.10,+ bytestring >= 0.10 && < 0.11,+ canteven-log >= 1.0 && < 2.1,+ directory >= 1.2.2.0 && < 1.3,+ exceptions >= 0.8.2 && < 0.9,+ filepath >= 1.4.0.0 && < 1.5,+ http-types >= 0.9.1 && < 0.10,+ mime-types >= 0.1.0.7 && < 0.2,+ monad-logger >= 0.3.19 && < 0.4,+ template-haskell >= 2.10.0.0 && < 2.12,+ text >= 1.2 && < 1.3,+ time >= 1.5.0.1 && < 1.7,+ transformers >= 0.4.2.0 && < 0.6,+ unix >= 2.7.1.0 && < 2.8,+ uuid >= 1.3.12 && < 1.4,+ wai >= 3.2 && < 3.3,+ wai-extra >= 3.0.8 && < 3.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall
src/Canteven/HTTP.hs view
@@ -13,17 +13,19 @@ requestLogging, logExceptionsAndContinue, setServer,+ staticSite, ) where import Canteven.Log.MonadLog (LoggerTImpl) import Control.Concurrent (threadDelay) import Control.Exception (SomeException)-import Control.Monad (void)+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.ByteString.Lazy (ByteString, fromStrict)+import Data.List ((\\))+import Data.Maybe (catMaybes) import Data.Monoid ((<>)) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8)@@ -31,19 +33,29 @@ 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)+ statusMessage, ok200)+import Network.Mime (defaultMimeLookup) import Network.Wai (Middleware, responseStatus, requestMethod, rawPathInfo, rawQueryString, Response, ResponseReceived, responseLBS,- modifyResponse)+ 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 {- | The class of things that can be read as http message entities. -} class FromEntity e where {- | Decode the entity, according to the specified content type. -}- decodeEntity :: Maybe ContentType -> ByteString -> DecodeResult e+ decodeEntity :: Maybe ContentType -> BSL.ByteString -> DecodeResult e {- | The class of things that can be used to generate http message entities. -}@@ -52,7 +64,7 @@ getContentType :: e -> ContentType {- | The bytes associated with the response entity. -}- getBytes :: e -> ByteString+ getBytes :: e -> BSL.ByteString {- | The result of trying to decode a request entity. -}@@ -69,7 +81,7 @@ {- | ContentType is an alias for ByteString. -}-type ContentType = ByteString+type ContentType = BSL.ByteString {- |@@ -100,7 +112,7 @@ responseLBS internalServerError500 [("Content-Type", "text/plain")] - (fromStrict . encodeUtf8 . pack+ (BSL.fromStrict . encodeUtf8 . pack $ "Internal Server Error. Error ID: " ++ show uuid) getUUID :: LoggingT IO UUID@@ -187,4 +199,84 @@ {- | 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)