webapp 0.1.2 → 0.2.0
raw patch · 27 files changed
+1321/−867 lines, 27 filesdep +aesondep +case-insensitivedep +regex-posixdep −attoparsecdep −cryptohashdep −css-text
Dependencies added: aeson, case-insensitive, regex-posix
Dependencies removed: attoparsec, cryptohash, css-text, data-default, directory, filepath, fsnotify, hashtables, hjsmin, mime-types, scotty, time, unordered-containers, wai-extra
Files
- CHANGELOG.md +21/−5
- README.md +14/−12
- Web/App.hs +14/−94
- Web/App/Assets.hs +0/−78
- Web/App/Cookie.hs +0/−66
- Web/App/Daemon.hs +0/−108
- Web/App/FileCache.hs +0/−159
- Web/App/HTTP.hs +58/−57
- Web/App/IO.hs +0/−66
- Web/App/Internal/Daemon.hs +108/−0
- Web/App/Internal/IO.hs +66/−0
- Web/App/Internal/Privileges.hs +38/−0
- Web/App/Internal/TerminalSize.hsc +61/−0
- Web/App/Main.hs +141/−0
- Web/App/Middleware/ForceSSL.hs +1/−0
- Web/App/Middleware/Gzip.hs +2/−2
- Web/App/Monad.hs +0/−73
- Web/App/Monad/Internal.hs +0/−14
- Web/App/Parameter.hs +112/−0
- Web/App/Path.hs +129/−0
- Web/App/Privileges.hs +0/−38
- Web/App/RouteT.hs +311/−0
- Web/App/State.hs +29/−0
- Web/App/Stream.hs +75/−0
- Web/App/TerminalSize.hsc +0/−61
- Web/App/WebApp.hs +119/−0
- webapp.cabal +22/−34
CHANGELOG.md view
@@ -1,8 +1,24 @@ # webapp changelog -v 0.0.1 - Initial release-v 0.0.2 - Fix omitted module in `webapp.cabal`: `Web.App.Monad.Internal`+v 0.0.1+ +- Initial release++v 0.0.2++- Fix omitted module in `webapp.cabal`: `Web.App.Monad.Internal`+ v 0.1.0- - Included a new example: a counter app with an additional CLI parser.- - Implemented a "util" CLI subcommand where you can "mount" an optparse-applicative @Parser@. See example.- - Fixed termination handlers. Previously, they weren't installed when using HTTPS due to a bug in warp-tls. This has been remedied. Additionally, these handlers would destroy the initial state, rather than the current state from the @TVar@.++- Included a new example: a counter app with an additional CLI parser.+- Implemented a "util" CLI subcommand where you can "mount" an optparse-applicative @Parser@. See example.+- Fixed termination handlers. Previously, they weren't installed when using HTTPS due to a bug in warp-tls. This has been remedied. Additionally, these handlers would destroy the initial state, rather than the current state from the @TVar@.++v 0.2.0+ +- Complete rewrite+- New WAI-based web framework+ - Routing with captures, regexes, and literals+ - Streaming body based around `writeBody` function+ - Allow data structures to be streamed via the 'ToStream' typeclass.+ - Typesafe parameter coersion
README.md view
@@ -1,11 +1,13 @@-# webapp - simple webapp scaffolding with state+# webapp - WAI web framework +Webapp is a web framework that is designed to provide everything needed to define & deploy a web app.+ Basic example: module Main where import Web.App- import Web.Scotty.Trans+ import qualified Control.Monad.State.Class as S instance WebAppState Integer where initState = return 0@@ -13,18 +15,18 @@ putStr "Counted: " print st - main = webappMain app "My Web App" "This is a demo web app"+ main = webappMainIO' app "My Web App" - app :: (ScottyError e) => ScottyT e (WebAppM Integer) ()+ app :: WebAppT Integer IO () app = do+ get "/" $ do+ addHeader "Content-Type" "text/plain"+ S.get >>= writeBody . show+ get "/add" $ do- modifyState (+1)+ S.state (((),) . (+) 1)+ redirect "/" get "/subtract" $ do- (State count) <- getState- putState (State count-1)- - get "/assets/:file" $ param "file" >>= loadAsset- - -There is also a module called `FileCache` which is available for loading cached files. It loads files into memory, MD5 sums them, compresses them, and then stores them in the cache.+ S.get >>= S.put . ((-) 1)+ redirect "/"
Web/App.hs view
@@ -6,107 +6,27 @@ Stability : experimental Portability : POSIX -Root modules of webapp.+Root module of webapp. -} module Web.App (- -- * Functions- webappMain,- -- * Exported Modules- module Web.App.Assets,- module Web.App.Cookie,- module Web.App.Daemon,- module Web.App.FileCache, module Web.App.HTTP,- module Web.App.IO,- module Web.App.Monad,- module Web.App.Middleware+ module Web.App.Main,+ module Web.App.Middleware,+ module Web.App.Path,+ module Web.App.RouteT,+ module Web.App.State,+ module Web.App.Stream,+ module Web.App.WebApp ) where -import Web.App.Assets-import Web.App.Cookie-import Web.App.Daemon-import Web.App.FileCache import Web.App.HTTP-import Web.App.IO-import Web.App.Monad-import Web.App.TerminalSize+import Web.App.Main import Web.App.Middleware--import Control.Applicative-import Options.Applicative-import System.Environment (getArgs)-import Web.Scotty.Trans (ScottyT,ScottyError)--data Cmd- = StartCommand {- startCmdDaemonize :: Bool,- _startCmdInsecure :: Bool,- _startCmdPort :: Int,- _startCmdHTTPSSLCert :: FilePath,- _startCmdHTTPSSLKey :: FilePath,- _startCmdOutputPath :: Maybe FilePath,- _startCmdErrorPath :: Maybe FilePath,- _startCmdPidPath :: FilePath- }- | StopCommand {- _stopCmdPidPath :: FilePath- }- | StatusCommand {- _statusCmdPidPath :: FilePath- }---- | Read commandline arguments and start app accordingly. When passing an--- additional CLI parser, it is made available under the @util@ subcommand.-webappMain :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ app to start- -> String -- ^ CLI title/description- -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand)- -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser'- -> IO ()-webappMain app title utilParser utilf = getArgs >>= getCommandArgs utilParser title >>= processArgs- where- processArgs (Right cmd) = f cmd- processArgs (Left utils) = utilf utils- f c@(StartCommand True _ _ _ _ _ _ pidPath) = do- daemonize pidPath $ f $ c { startCmdDaemonize = False }- f (StartCommand False False port crt key out err _) = do- redirectStdout out- redirectStderr err- startHTTPS app port crt key- f (StartCommand False True port _ _ out err _) = do- redirectStdout out- redirectStderr err- startHTTP app port- f (StopCommand pidPath) = daemonKill 4 pidPath- f (StatusCommand pidPath) = daemonRunning pidPath >>= putStrLn . showStatus- showStatus True = "running"- showStatus False = "stopped"--getCommandArgs :: Maybe (Parser a) -> String -> [String] -> IO (Either a Cmd)-getCommandArgs utilParser title args = do- w <- maybe 80 snd <$> getTermSize- handleParseResult $ execParserPure (pprefs w) parser args- where- pprefs = ParserPrefs "" False False True- parser = info (helper <*> ((sp utilParser) <|> parseStart)) (fullDesc <> header title)- sp Nothing = subparser subCommands- sp (Just util) = subparser $ subCommands <> (mkcmd "util" "Utilities associated with the application" (Left <$> util))- subCommands = (mkcmd "start" "Start the application server" parseStart) <>- (mkcmd "stop" "Stop the application server" parseStop) <>- (mkcmd "status" "Determine if the application server is running" parseStatus)- parseStart = fmap Right $ StartCommand- <$> (flag False True $ short 'd' <> long "daemonize" <> help "run the application server daemonized")- <*> (flag False True $ short 'i' <> long "insecure" <> help "run the application server over insecure HTTP")- <*> (option auto $ opt "port" 'p' "PORT" (Just 3000) "port to run the application server on")- <*> (strOption $ opt "https-crt" 'c' "FILEPATH" (Just "server.crt") "SSL certificate file")- <*> (strOption $ opt "https-key" 'k' "FILEPATH" (Just "server.key") "SSL private key file")- <*> (optional $ strOption $ opt "stdout" 'o' "FILEPATH" Nothing "redirect standard output to FILEPATH")- <*> (optional $ strOption $ opt "stderr" 'e' "FILEPATH" Nothing "redirect standard error to FILEPATH")- <*> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "when daemonizing, write the PID to FILEPATH")- parseStop = Right <$> StopCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")- parseStatus = Right <$> StatusCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")- opt lng shrt mvar (Just defVal) hlp = (long lng <> short shrt <> metavar mvar <> value defVal <> help hlp)- opt lng shrt mvar Nothing hlp = (long lng <> short shrt <> metavar mvar <> help hlp)- mkcmd cmd desc p = command cmd $ info (helper <*> p) $ progDesc desc+import Web.App.Path+import Web.App.RouteT+import Web.App.State+import Web.App.Stream+import Web.App.WebApp
− Web/App/Assets.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{-|-Module : Web.App.Assets-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--General web app operations related to managing assets.--}--module Web.App.Assets-(- loadAsset-)-where- -import Web.App.Monad-import qualified Web.App.FileCache as FC--import Web.Scotty.Trans as Scotty--import Network.HTTP.Types.Status (Status(..))-import Network.Mime--import System.FilePath-import System.Directory--import Control.Monad-import Control.Monad.IO.Class--import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Encoding as TL-import qualified Data.Text.Lazy.Builder as TL--import qualified Text.CSS.Parse as CSS (parseNestedBlocks)-import qualified Text.CSS.Render as CSS (renderNestedBlocks)-import qualified Text.Jasmine as JS (minifym)---- | Loads an asset from the 'FileCache' associated with the 'WebAppM' monad.-loadAsset :: (ScottyError e, WebAppState s) => FilePath -- ^ 'FilePath' relative to @assets/@ to load- -> ActionT e (WebAppM s) ()-loadAsset assetsPath = do- cache <- getCache- exists <- liftIO $ doesFileExist relPath- if not exists- then doesntExist $ B.pack relPath- else loadFromCache cache- where- mimetype = TL.fromStrict . T.decodeUtf8 . defaultMimeLookup . T.pack . takeFileName $ assetsPath- relPath = "assets/" ++ assetsPath- doesntExist pth = status . Status 404 $ mconcat ["File ", pth, " does not exist."]- loadFromCache cache = (liftIO $ FC.lookup cache assetsPath) >>= (f cache)- f _ (Just (Left err)) = status . Status 500 $ B.pack err- f _ (Just (Right (cached, md5))) = do- setHeader "Content-Type" $ mconcat [mimetype, "; charset=utf-8"]- Scotty.addHeader "Vary" "Accept-Encoding"- Scotty.setHeader "Content-Encoding" "gzip" -- files in FileCaches are gzipped- Scotty.header "If-None-Match" >>= h . maybe False (== md5')- where- md5' = TL.decodeUtf8 $ BL.fromStrict md5- h True = Scotty.status $ Status 304 ""- h False = do- Scotty.setHeader "ETag" md5'- Scotty.raw $ BL.fromStrict cached- f cache Nothing = do- void $ liftIO $ FC.register' cache assetsPath (g mimetype)- loadFromCache cache- builderToBS = BL.toStrict . TL.encodeUtf8 . TL.toLazyText- g "application/javascript" = fmap BL.toStrict . JS.minifym . BL.fromStrict- g "text/css" = fmap (builderToBS . CSS.renderNestedBlocks) . CSS.parseNestedBlocks . T.decodeUtf8- g _ = Right
− Web/App/Cookie.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}--{-|-Module : Web.App.Cookie-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : Cross-Platform--Manipulate HTTP cookies--}--module Web.App.Cookie -(- -- * Data Structures- Cookie(..),- -- * Cookie Parsing- parseCookie-)-where--import Control.Applicative-import Data.Default-import Data.Char-import Data.Time.Format-import Data.Time.Clock (UTCTime)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as H-import qualified Data.ByteString.Char8 as B-import Data.Attoparsec.ByteString.Char8 as A---- ^ Data structure representing an HTTP cookie-data Cookie = Cookie {- cookiePairs :: HashMap String String,- cookiePath :: Maybe String,- cookieDomain :: Maybe String,- cookieExpires :: Maybe UTCTime,- cookieSecure :: Bool,- cookieHttpOnly :: Bool-} deriving (Show)--instance Default Cookie where- def = Cookie H.empty Nothing Nothing Nothing False False---- |Parse a 'Cookie' from a @Cookie@ header-parseCookie :: B.ByteString -- ^ value of a @Cookie@ header- -> Maybe Cookie-parseCookie = fmap (lx def) . maybeResult . flip feed "" . parse pairs -- @flip feed ""@ is required because @pairs@ can take an indefinite amount of input- where- -- RFC 1123 date parser- parseCookieDate = parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"- -- lexer- lx c [] = c- lx c (("secure",_):xs) = lx (c { cookieSecure = True }) xs- lx c (("httponly",_):xs) = lx (c { cookieHttpOnly = True }) xs- lx c (("path",v):xs) = lx (c { cookiePath = Just v }) xs- lx c (("domain",v):xs) = lx (c { cookieDomain = Just v }) xs- lx c (("expires",v):xs) = lx (c { cookieExpires = parseCookieDate v }) xs- lx c ((k,v):xs) = lx (c { cookiePairs = H.insert k v $ cookiePairs c }) xs- -- grammar- pairs = (:) <$> pair <*> (many' $ ";" *> skipSpace *> pair)- pair = (,) <$> attr <*> val- attr = map toLower <$> many' letter_ascii- val = option "" $ "=" *> q *> many' letter_ascii <* q- q = "\"" <|> "'" <|> pure "" -- RFC 6265 states that cookies' values can be quoted
− Web/App/Daemon.hs
@@ -1,108 +0,0 @@-{-|-Module : Web.App.Daemon-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Operations related to running a background process--}--module Web.App.Daemon-(- -- * Daemon Operations- daemonize,- daemonRunning,- daemonKill,- pidWrite,- pidRead,- pidKill,- pidLive-)-where- -import Web.App.IO- -import Control.Exception-import Control.Monad (when,void)--import System.Exit-import System.Posix---- |Kill a daemon-daemonKill :: Int -- ^ Timeout- -> FilePath -- ^ 'FilePath' of a PID file- -> IO ()-daemonKill = pidKill---- |Determine if a daemon is still running-daemonRunning :: FilePath -- ^ 'FilePath' of a PID file- -> IO Bool-daemonRunning pidFile = fileExist pidFile >>= f- where- f False = return False- f True = pidRead pidFile >>= g- g Nothing = return False- g (Just pid) = pidLive pid---- |Start a daemonized process-daemonize :: FilePath -- ^ 'FilePath' of a PID file- -> IO () -- ^ Action to execute daemonized- -> IO ()-daemonize pidFile program = do- void $ forkProcess $ do- void $ createSession- void $ forkProcess $ do- pidWrite pidFile- redirectStdout $ Just "/dev/null"- redirectStderr $ Just "/dev/null"- redirectStdin $ Just "/dev/null"- closeFd stdInput -- close STDIN- void $ installHandler sigHUP Ignore Nothing- program- exitImmediately ExitSuccess- exitImmediately ExitSuccess---- Wait for a process to exit--- if it is still running after @secs@--- seconds, "shoot it in the head"-wait :: Int -> CPid -> IO ()-wait secs pid = (when <$> pidLive pid) >>= \w -> w f- where f | secs > 0 = do- usleep 1000000 -- sleep for 1 second- wait (secs-1) pid- | otherwise = do- putStrLn $ "force killing PID " ++ (show pid)- signalProcess sigKILL pid--{- Write the process's PID to a file -}-pidWrite :: FilePath -> IO ()-pidWrite pidPath = getProcessID >>= writeFile pidPath . show--{- Read a PID from a file -}-pidRead :: FilePath -> IO (Maybe CPid)-pidRead pidFile = fileExist pidFile >>= f where- f True = fmap (Just . read) . readFile $ pidFile- f False = return Nothing--{- Determine if a PID is live -}-pidLive :: CPid -> IO Bool-pidLive pid = (getProcessPriority pid >> return True) `catch` f where- f :: IOException -> IO Bool- f _ = return False- -{- Kill a PID from a file with a timeout -}-pidKill :: Int -> FilePath -> IO ()-pidKill timeout pidFile = fileExist pidFile >>= f- where- f False = return ()- f True = do- pidRead pidFile >>= g- removeLink pidFile- g Nothing = return ()- g (Just pid) = pidLive pid >>= h pid- h _ False = return ()- h pid True = do- signalProcess sigTERM pid- wait timeout pid
− Web/App/FileCache.hs
@@ -1,159 +0,0 @@-{-# LANGUAGE TupleSections #-}--{-|-Module : Web.App.FileCache-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Memory-map style file cache. Watches a directory and updates the cache as changes-to files occur. Stores GZIP compressed representations of files and MD5 sums of the-uncompressed representations of the cached files.--}--module Web.App.FileCache-(- -- * Types- -- * Data Structures- FileCache(..),- -- * Type Aliases- Entry,- FileTransform,- -- * Creation & Destruction- newFileCache,- teardownFileCache,- -- * Cache Operations- lookup,- register,- register',- register'',- refresh,- invalidate-)-where--import System.FSNotify-import System.Directory-import System.FilePath--import qualified Data.HashTable.IO as HT-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.ByteString.Char8 as B-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Base16 as B16--import Control.Monad-import Control.Concurrent-import Control.Exception (try, displayException, IOException)--import qualified Codec.Compression.GZip as GZIP (compress)--import qualified Crypto.Hash.MD5 as MD5 (hash)--import Prelude hiding (lookup)--type HashTable k v = HT.CuckooHashTable k v---- |Takes the raw file contents and returns either an error (String)--- or the transformed files contents-type FileTransform = (ByteString -> Either String ByteString)---- |Either an error message (Left) or a tuple (Right)--- containing the GZIP'd file contents (fst) and the--- MD5 sum of the uncompressed file contents (snd)-type Entry = Either String (ByteString, ByteString)---- |A data structure representing a file cache. Most people--- shouldn't need to modify this structure.-data FileCache = FileCache {- fileCacheBasePath :: FilePath, -- ^ 'FileCache''s base path. All 'FilePath' keys in 'fileCacheHashTable' are relative to this path.- fileCacheHashTable :: MVar (HashTable FilePath (Entry, FileTransform)), -- ^ See 'fileCachePath'- fileCacheFSMonitor :: WatchManager -- ^ FSMonitor structure that watches 'fileCacheBasePath'-}---- |Creates a new 'FileCache'-newFileCache :: FilePath -- ^ Base path of the 'FileCache' to be created- -> IO FileCache -- ^ The resulting 'FileCache'-newFileCache path@('/':_) = do -- create a file cache based on an absolute path- fc <- FileCache (addTrailingPathSeparator path) <$> (HT.new >>= newMVar) <*> startManager- startWatching fc- return fc- where- startWatching fc@(FileCache bp _ m) = void $ watchTree m bp (const True) (f fc)- f _ (Added _ _) = return ()- f fc@(FileCache bp _ _) (Modified pth _) = refresh fc (makeRelative bp pth)- f fc@(FileCache bp _ _) (Removed pth _) = invalidate fc (makeRelative bp pth)-newFileCache path = mkAbsPath path >>= newFileCache -- resolve a relative path to an absolute path- where mkAbsPath p = (</>) <$> getCurrentDirectory <*> pure p---- |Frees resources associated with a 'FileCache'-teardownFileCache :: FileCache -> IO ()-teardownFileCache = stopManager . fileCacheFSMonitor---- |Lookup an entry in the cache-lookup :: FileCache -- ^ 'FileCache' to be used- -> FilePath -- ^ 'FilePath' to look up- -> IO (Maybe Entry) -- ^ 'Entry' for the provided 'FilePath'-lookup (FileCache _ mht _) k = withMVar mht $ \ht -> fmap fst <$> HT.lookup ht k---- |Register a 'FilePath' and 'FileTransform' with the cache-register :: FileCache -- ^ 'FileCache' to register in- -> Int -- ^ 'Entry' timeout. A timeout of 0 indicates the entry should never expire- -> FilePath -- ^ 'FilePath' to register- -> FileTransform -- ^ 'FileTransform' for the 'Entry' to be generated- -> IO Entry -- ^ Entry for 'FilePath'-register fc@(FileCache bp mht _) timeout k f = do- v <- xformedReadFileE f (bp </> k)- withMVar mht $ \ht -> HT.insert ht k (v, f)- when (timeout > 0) $ void $ forkIO $ a- return v- where- a = do- threadDelay timeout- invalidate fc k- --- |'register' with a zero timeout-register' :: FileCache -> FilePath -> FileTransform -> IO Entry-register' fc k f = register fc 0 k f---- |'register' with a zero timeout and no @FileTransform@-register'' :: FileCache -> FilePath -> IO Entry-register'' fc k = register fc 0 k Right---- |Force reload an entry in the cache-refresh :: FileCache -- ^ 'FileCache' to be used- -> FilePath -- ^ 'FilePath' to reload- -> IO ()-refresh (FileCache bp mht _) k = withMVar mht f- where- f ht = HT.lookup ht k >>= g ht . fmap snd- g ht (Just xform) = xformedReadFileE xform (bp </> k) >>= HT.insert ht k . (,xform)- g _ Nothing = return ()---- @invalidate@--- invalidate an entry in the cache--- fc -> the cache--- k -> the key used; Should be a path relative to the FileCache's base path--- |Invalidate an entry in a 'FileCache'-invalidate :: FileCache -- ^ 'FileCache' to be used- -> FilePath -- ^ 'FilePath' to invalidate- -> IO ()-invalidate (FileCache _ mht _) k = withMVar mht (flip HT.delete k)--{- Internal -}--readFileE :: FilePath -> IO (Either String ByteString)-readFileE fp = (either (Left . displayException) Right) <$> readF- where- readF :: IO (Either IOException ByteString)- readF = try $ B.readFile fp---- returns (contents, md5)-xformedReadFileE :: FileTransform -> FilePath -> IO Entry-xformedReadFileE f fp = readFileE fp >>= return . either Left (buildEntry . f)- where- buildEntry = either Left (\cnts -> Right (compress cnts, md5 cnts))- compress = BL.toStrict . GZIP.compress . BL.fromStrict- md5 = B16.encode . MD5.hash
Web/App/HTTP.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, RankNTypes, ScopedTypeVariables #-} {-| Module : Web.App.HTTP@@ -20,23 +20,19 @@ ) where -import Web.App.Monad-import Web.App.Monad.Internal-import Web.App.FileCache import Web.App.Middleware-import Web.App.Privileges+import Web.App.Internal.Privileges+import Web.App.RouteT+import Web.App.State+import Web.App.WebApp import Control.Monad-import Control.Monad.Reader (runReaderT)-import Control.Concurrent.STM--import Web.Scotty.Trans as Scotty+import Control.Monad.IO.Class import Network.Wai (Application,Middleware)-import Network.Wai.HTTP2 (promoteApplication,HTTP2Application)-import Network.Wai.Handler.Warp (defaultSettings,setPort,getPort,getHost,setBeforeMainLoop,setInstallShutdownHandler,runHTTP2Settings)-import Network.Wai.Handler.WarpTLS (certFile,defaultTlsSettings,keyFile,TLSSettings(..),runHTTP2TLSSocket,OnInsecure(..))-import Network.Wai.Handler.Warp.Internal (Settings(..))+import Network.Wai.Handler.Warp (defaultSettings,getPort,getHost,runSettings)+import Network.Wai.Handler.WarpTLS (tlsSettings,runTLSSocket,TLSSettings(..),OnInsecure(..))+import Network.Wai.Handler.Warp.Internal -- (Settings(..)) import Network.Socket (sClose, withSocketsDo) import Data.Streaming.Network (bindPortTCP) import Control.Exception (bracket)@@ -45,59 +41,64 @@ import System.Posix -- |Start an insecure HTTP server.-startHTTP :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ Scotty app to serve- -> Int -- ^ Port to which to bind- -> IO ()-startHTTP app port = serveApp runHTTP2Settings app port [gzip 860]+startHTTP :: (WebAppState s, MonadIO m)+ => WebApp s m -- ^ Scotty app to serve+ -> (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@+ -> Int -- ^ Port to which to bind+ -> IO ()+startHTTP app runToIO port = serveApp runSettings runToIO app port [gzip 860] --- TODO: fix setInstallShutdownHandler not working -- |Start a secure HTTPS server. Please note that most HTTP/2-compatible browswers -- require HTTPS in order to upgrade to HTTP/2.-startHTTPS :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ Scotty app to serve- -> Int -- ^ Port to which to bind- -> FilePath -- ^ 'FilePath' to an SSL certificate- -> FilePath -- ^ 'FilePath' to an SSL private key- -> IO ()-startHTTPS app port cert key = do- serveApp (runHTTP2TLSHandled tlsset) app port [gzip 860, forceSSL]- where tlsset = defaultTlsSettings { keyFile = key, certFile = cert, onInsecure = AllowInsecure }- +startHTTPS :: (WebAppState s, MonadIO m)+ => WebApp s m -- ^ Scotty app to serve+ -> (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@+ -> Int -- ^ Port to which to bind+ -> FilePath -- ^ 'FilePath' to an SSL certificate+ -> FilePath -- ^ 'FilePath' to an SSL private key+ -> IO ()+startHTTPS app runToIO port cert key = serveApp (runTLSHandled tlsset) runToIO app port mw+ where mw = [gzip 860, forceSSL]+ tlsset = (tlsSettings cert key) { onInsecure = AllowInsecure } {- Internal -}- -serveApp :: (ScottyError e, WebAppState s) => (Settings -> HTTP2Application -> Application -> IO ()) -- ^ fnc to serve resulting app- -> ScottyT e (WebAppM s) () -- ^ scotty app to serve- -> Int -- ^ port to serve on- -> [Middleware]- -> IO ()-serveApp serve app port middlewares = do- st <- newTVarIO =<< (WebApp <$> (newFileCache "assets/") <*> initState)-- webapp- wai <- scottyAppT (\m -> runReaderT (runWebAppM m) st) $ do- mapM_ middleware middlewares- middleware $ gzip 860 -- min length to GZIP- middleware $ forceSSL- app- serve (warpSettings st) (promoteApplication wai) wai++-- |Serves a @'WebAppT' s m ()@ given a serving function, "dropping"+-- function @(m 'RouteResult' -> 'IO' 'RouteResult')@, port, and middlewares.+serveApp :: (WebAppState s, MonadIO m)+ => (Settings -> Application -> IO ()) -- ^ serving function+ -> (m RouteResult -> IO RouteResult) -- ^ "dropping" function+ -> WebApp s m -- ^ app to serve+ -> Int -- ^ port to serve on+ -> [Middleware] -- ^ middleware to add to the app+ -> IO ()+serveApp serve runToIO app port mws = do+ (wai, teardown) <- toApplication runToIO $ mconcat $ app:map middleware mws+ serve (warpSettings teardown) wai where- warpSettings tvar = setBeforeMainLoop before- $ setInstallShutdownHandler (installShutdown tvar)- $ setPort port defaultSettings+ warpSettings td = defaultSettings {+ settingsPort = port,+ settingsInstallShutdownHandler = installShutdown td,+ settingsBeforeMainLoop = before,+ settingsHTTP2Enabled = True -- explicitly enable HTTP2 support+ } before = resignPrivileges "daemon"- installShutdown tvar killSockets = do- void $ installHandler sigTERM (handler tvar killSockets) Nothing- void $ installHandler sigINT (handler tvar killSockets) Nothing- handler tvar killSockets = Catch $ do- (WebApp cache st) <- readTVarIO tvar+ installShutdown teardown killSockets = do+ void $ installHandler sigTERM (handler teardown killSockets) Nothing+ void $ installHandler sigINT (handler teardown killSockets) Nothing+ handler teardown killSockets = Catch $ do void $ killSockets- teardownFileCache cache- destroyState st+ void $ teardown exitImmediately ExitSuccess --- | Serve an HTTP2 application over TLS, obeying 'settingsInstallShutdownHandler'.+-- |Serve an application over TLS, obeying 'settingsInstallShutdownHandler'. -- This setting is ignored in WarpTLS due to a bug (gasp!). See -- https://github.com/yesodweb/wai/issues/483-runHTTP2TLSHandled :: TLSSettings -> Settings -> HTTP2Application -> Application -> IO ()-runHTTP2TLSHandled tset set wai2 wai = withSocketsDo $- bracket (bindPortTCP (getPort set) (getHost set)) sClose $ \socket -> do- settingsInstallShutdownHandler set (sClose socket)- runHTTP2TLSSocket tset set socket wai2 wai+runTLSHandled :: TLSSettings -> Settings -> Application -> IO ()+runTLSHandled tset set wai = withSocketsDo $ bracket acquire destroy f+ where+ acquire = bindPortTCP (getPort set) (getHost set)+ destroy = sClose+ f socket = do+ settingsInstallShutdownHandler set (sClose socket)+ runTLSSocket tset set socket wai
− Web/App/IO.hs
@@ -1,66 +0,0 @@-{-|-Module : Web.App.IO-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Redirect standard input, output, and error. These functions will disable buffering-after they swap file handles because buffering causes funny behavior with respect-to writing to files. (buffering works fine with terminals/consoles).--}--module Web.App.IO-(- -- * IO Redirection- redirectStdin,- redirectStdout,- redirectStderr-)-where--import Control.Monad (when,void)--import System.IO-import System.Posix---- | Redirect standard input.-redirectStdin :: Maybe FilePath -- ^ File to which standard input is redirected- -> IO ()-redirectStdin Nothing = return ()-redirectStdin (Just path) = do- swapFd stdInput path- hSetBuffering stdin NoBuffering---- | Redirect standard output.-redirectStdout :: Maybe FilePath -- ^ File to which standard output is redirected- -> IO ()-redirectStdout Nothing = return ()-redirectStdout (Just path) = do- swapFd stdOutput path- hSetBuffering stdout NoBuffering---- | Redirect standard error.-redirectStderr :: Maybe FilePath -- ^ File to which standard error is redirected- -> IO ()-redirectStderr Nothing = return ()-redirectStderr (Just path) = do- swapFd stdError path- hSetBuffering stderr NoBuffering--{- Internal -}--safeOpenFd :: FilePath -> IO Fd-safeOpenFd p = do- exists <- fileExist p- when (not exists) $ writeFile p ""- fd <- openFd p ReadWrite Nothing defaultFileFlags- setFdOption fd AppendOnWrite True- return fd--swapFd :: Fd -> FilePath -> IO ()-swapFd old path = do- new <- safeOpenFd path- void $ dupTo new old- closeFd new
+ Web/App/Internal/Daemon.hs view
@@ -0,0 +1,108 @@+{-|+Module : Web.App.Daemon+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Operations related to running a background process+-}++module Web.App.Internal.Daemon+(+ -- * Daemon Operations+ daemonize,+ daemonRunning,+ daemonKill,+ pidWrite,+ pidRead,+ pidKill,+ pidLive+)+where+ +import Web.App.Internal.IO+ +import Control.Exception+import Control.Monad (when,void)++import System.Exit+import System.Posix++-- |Kill a daemon+daemonKill :: Int -- ^ Timeout+ -> FilePath -- ^ 'FilePath' of a PID file+ -> IO ()+daemonKill = pidKill++-- |Determine if a daemon is still running+daemonRunning :: FilePath -- ^ 'FilePath' of a PID file+ -> IO Bool+daemonRunning pidFile = fileExist pidFile >>= f+ where+ f False = return False+ f True = pidRead pidFile >>= g+ g Nothing = return False+ g (Just pid) = pidLive pid++-- |Start a daemonized process+daemonize :: FilePath -- ^ 'FilePath' of a PID file+ -> IO () -- ^ Action to execute daemonized+ -> IO ()+daemonize pidFile program = do+ void $ forkProcess $ do+ void $ createSession+ void $ forkProcess $ do+ pidWrite pidFile+ redirectStdout $ Just "/dev/null"+ redirectStderr $ Just "/dev/null"+ redirectStdin $ Just "/dev/null"+ closeFd stdInput -- close STDIN+ void $ installHandler sigHUP Ignore Nothing+ program+ exitImmediately ExitSuccess+ exitImmediately ExitSuccess++-- Wait for a process to exit+-- if it is still running after @secs@+-- seconds, "shoot it in the head"+wait :: Int -> CPid -> IO ()+wait secs pid = (when <$> pidLive pid) >>= \w -> w f+ where f | secs > 0 = do+ usleep 1000000 -- sleep for 1 second+ wait (secs-1) pid+ | otherwise = do+ putStrLn $ "force killing PID " ++ (show pid)+ signalProcess sigKILL pid++-- |Write the process's PID to a file+pidWrite :: FilePath -> IO ()+pidWrite pidPath = getProcessID >>= writeFile pidPath . show++-- |Read a PID from a file+pidRead :: FilePath -> IO (Maybe CPid)+pidRead pidFile = fileExist pidFile >>= f where+ f True = fmap (Just . read) . readFile $ pidFile+ f False = return Nothing++-- |Determine if a PID is live+pidLive :: CPid -> IO Bool+pidLive pid = (getProcessPriority pid >> return True) `catch` f where+ f :: IOException -> IO Bool+ f _ = return False+ +-- |Kill a PID from a file with a timeout+pidKill :: Int -> FilePath -> IO ()+pidKill timeout pidFile = fileExist pidFile >>= f+ where+ f False = return ()+ f True = do+ pidRead pidFile >>= g+ removeLink pidFile+ g Nothing = return ()+ g (Just pid) = pidLive pid >>= h pid+ h _ False = return ()+ h pid True = do+ signalProcess sigTERM pid+ wait timeout pid
+ Web/App/Internal/IO.hs view
@@ -0,0 +1,66 @@+{-|+Module : Web.App.IO+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Redirect standard input, output, and error. These functions will disable buffering+after they swap file handles because buffering causes funny behavior with respect+to writing to files. (buffering works fine with terminals/consoles).+-}++module Web.App.Internal.IO+(+ -- * IO Redirection+ redirectStdin,+ redirectStdout,+ redirectStderr+)+where++import Control.Monad (when,void)++import System.IO+import System.Posix++-- | Redirect standard input.+redirectStdin :: Maybe FilePath -- ^ File to which standard input is redirected+ -> IO ()+redirectStdin Nothing = return ()+redirectStdin (Just path) = do+ swapFd stdInput path+ hSetBuffering stdin NoBuffering++-- | Redirect standard output.+redirectStdout :: Maybe FilePath -- ^ File to which standard output is redirected+ -> IO ()+redirectStdout Nothing = return ()+redirectStdout (Just path) = do+ swapFd stdOutput path+ hSetBuffering stdout NoBuffering++-- | Redirect standard error.+redirectStderr :: Maybe FilePath -- ^ File to which standard error is redirected+ -> IO ()+redirectStderr Nothing = return ()+redirectStderr (Just path) = do+ swapFd stdError path+ hSetBuffering stderr NoBuffering++{- Internal -}++safeOpenFd :: FilePath -> IO Fd+safeOpenFd p = do+ exists <- fileExist p+ when (not exists) $ writeFile p ""+ fd <- openFd p ReadWrite Nothing defaultFileFlags+ setFdOption fd AppendOnWrite True+ return fd++swapFd :: Fd -> FilePath -> IO ()+swapFd old path = do+ new <- safeOpenFd path+ void $ dupTo new old+ closeFd new
+ Web/App/Internal/Privileges.hs view
@@ -0,0 +1,38 @@+{-|+Module : Web.App.Privileges+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Determine when the process is being ran as root.+-}++module Web.App.Internal.Privileges+(+ isPrivileged,+ whenPrivileged,+ resignPrivileges+)+where++import Control.Monad+import System.Posix++-- | Determine if the process is being ran as root+isPrivileged :: IO Bool+isPrivileged = ((==) 0) <$> getEffectiveUserID++-- | Perform an action when ran as root+whenPrivileged :: IO () -- ^ The action to be performed+ -> IO ()+whenPrivileged act = do+ privileged <- isPrivileged+ when privileged act+ +-- | Drop root privileges+resignPrivileges :: String -- ^ Name of user to "become"+ -> IO ()+resignPrivileges user = whenPrivileged $ do+ getUserEntryForName user >>= setUserID . userID
+ Web/App/Internal/TerminalSize.hsc view
@@ -0,0 +1,61 @@+{-# LANGUAGE ForeignFunctionInterface #-}++{-|+Module : Web.App.TerminalSize+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Get the size of the terminal. Adapted from http://stackoverflow.com/questions/12806053/get-terminal-width-haskell.+-}++module Web.App.Internal.TerminalSize+(+ -- * Terminal Size+ getTermSize+)+where++import Foreign+import Foreign.C.Error+import Foreign.C.Types++import Control.Monad as M (void)++#include <sys/ioctl.h>+#include <unistd.h>++-- Trick for calculating alignment of a type, taken from+-- http://www.haskell.org/haskellwiki/FFICookBook#Working_with_structs+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++-- @xpixel@ and @ypixel@ fields are unused,+-- so they've been omitted.+data WinSize = WinSize CUShort CUShort -- row, col++instance Storable WinSize where+ sizeOf _ = (#size struct winsize)+ alignment _ = (#alignment struct winsize) + peek ptr = WinSize+ <$> (#peek struct winsize, ws_row) ptr+ <*> (#peek struct winsize, ws_col) ptr+ poke ptr (WinSize row col) = do+ (#poke struct winsize, ws_row) ptr row+ (#poke struct winsize, ws_col) ptr col++foreign import ccall "sys/ioctl.h ioctl"+ ioctl :: CInt -> CInt -> Ptr WinSize -> IO CInt++-- | Get the size of the terminal.+getTermSize :: IO (Maybe (Int, Int)) -- ^ @(rows, columns)@+getTermSize = with (WinSize 0 0) $ \ws -> do+ resetErrno+ M.void $ ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws+ err <- getErrno+ if isValidErrno err+ then do+ WinSize row col <- peek ws+ return $ Just (fromIntegral row, fromIntegral col)+ else return Nothing+
+ Web/App/Main.hs view
@@ -0,0 +1,141 @@+{-|+Module : Web.App.Main+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Main functions for running webapps. They provide a CLI interface+to the Web.App.HTTP module. They are designed to be used like++@+module Main where++import Web.App++main :: IO ()+main = webappMain' app "My Application!"+@++-}++module Web.App.Main+(+ webappMain,+ webappMain',+ webappMainIO,+ webappMainIO'+)+where++import Web.App.WebApp+import Web.App.RouteT (RouteResult)+import Web.App.State+import Web.App.HTTP+import Web.App.Internal.IO+import Web.App.Internal.Daemon+import Web.App.Internal.TerminalSize++import Control.Monad.IO.Class++import Control.Applicative+import Options.Applicative+import System.Environment (getArgs)++data Cmd+ = StartCommand {+ startCmdDaemonize :: Bool,+ _startCmdInsecure :: Bool,+ _startCmdPort :: Int,+ _startCmdHTTPSSLCert :: FilePath,+ _startCmdHTTPSSLKey :: FilePath,+ _startCmdOutputPath :: Maybe FilePath,+ _startCmdErrorPath :: Maybe FilePath,+ _startCmdPidPath :: FilePath+ }+ | StopCommand {+ _stopCmdPidPath :: FilePath+ }+ | StatusCommand {+ _statusCmdPidPath :: FilePath+ }+ +-- |Like 'webappMainIO' without the CLI extension arguments.+webappMainIO' :: (WebAppState s)+ => WebApp s IO -- ^ app to start+ -> String -- ^ CLI title/description+ -> IO ()+webappMainIO' a d = webappMainIO a d Nothing (const $ return ())+ +-- |Run a webapp based on IO.+webappMainIO :: (WebAppState s)+ => WebApp s IO -- ^ app to start+ -> String -- ^ CLI title/description+ -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand)+ -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser'+ -> IO ()+webappMainIO = webappMain id++-- |Like 'webappMain' without the CLI extension arguments.+webappMain' :: (WebAppState s, MonadIO m)+ => (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@+ -> WebApp s m -- ^ app to start+ -> String -- ^ CLI title/description+ -> IO ()+webappMain' f a d = webappMain f a d Nothing (const $ return ())++-- | Read commandline arguments and start webapp accordingly. When passing an+-- additional CLI parser, it is made available under the @util@ subcommand.+webappMain :: (WebAppState s, MonadIO m)+ => (m RouteResult -> IO RouteResult) -- ^ action to eval a monadic computation in @m@ in @IO@+ -> WebApp s m -- ^ app to start+ -> String -- ^ CLI title/description+ -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand)+ -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser'+ -> IO ()+webappMain runToIO app title utilParser utilf = getArgs >>= getCommandArgs utilParser title >>= processArgs+ where+ processArgs (Right cmd) = f cmd+ processArgs (Left utils) = utilf utils+ f c@(StartCommand True _ _ _ _ _ _ pidPath) = do+ daemonize pidPath $ f $ c { startCmdDaemonize = False }+ f (StartCommand False False port crt key out err _) = do+ redirectStdout out+ redirectStderr err+ startHTTPS app runToIO port crt key+ f (StartCommand False True port _ _ out err _) = do+ redirectStdout out+ redirectStderr err+ startHTTP app runToIO port+ f (StopCommand pidPath) = daemonKill 4 pidPath+ f (StatusCommand pidPath) = daemonRunning pidPath >>= putStrLn . showStatus+ showStatus True = "running"+ showStatus False = "stopped"++getCommandArgs :: Maybe (Parser a) -> String -> [String] -> IO (Either a Cmd)+getCommandArgs utilParser title args = do+ w <- maybe 80 snd <$> getTermSize+ handleParseResult $ execParserPure (pprefs w) parser args+ where+ pprefs = ParserPrefs "" False False True+ parser = info (helper <*> ((sp utilParser) <|> parseStart)) (fullDesc <> header title)+ sp Nothing = subparser subCommands+ sp (Just util) = subparser $ subCommands <> (mkcmd "util" "Utilities associated with the application" (Left <$> util))+ subCommands = (mkcmd "start" "Start the application server" parseStart) <>+ (mkcmd "stop" "Stop the application server" parseStop) <>+ (mkcmd "status" "Determine if the application server is running" parseStatus)+ parseStart = fmap Right $ StartCommand+ <$> (flag False True $ short 'd' <> long "daemonize" <> help "run the application server daemonized")+ <*> (flag False True $ short 'i' <> long "insecure" <> help "run the application server over insecure HTTP")+ <*> (option auto $ opt "port" 'p' "PORT" (Just 3000) "port to run the application server on")+ <*> (strOption $ opt "https-crt" 'c' "FILEPATH" (Just "server.crt") "SSL certificate file")+ <*> (strOption $ opt "https-key" 'k' "FILEPATH" (Just "server.key") "SSL private key file")+ <*> (optional $ strOption $ opt "stdout" 'o' "FILEPATH" Nothing "redirect standard output to FILEPATH")+ <*> (optional $ strOption $ opt "stderr" 'e' "FILEPATH" Nothing "redirect standard error to FILEPATH")+ <*> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "when daemonizing, write the PID to FILEPATH")+ parseStop = Right <$> StopCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")+ parseStatus = Right <$> StatusCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")+ opt lng shrt mvar (Just defVal) hlp = (long lng <> short shrt <> metavar mvar <> value defVal <> help hlp)+ opt lng shrt mvar Nothing hlp = (long lng <> short shrt <> metavar mvar <> help hlp)+ mkcmd cmd desc p = command cmd $ info (helper <*> p) $ progDesc desc
Web/App/Middleware/ForceSSL.hs view
@@ -21,6 +21,7 @@ import Data.Monoid import Network.HTTP.Types.Status (status301) +-- |Middleware to force SSL traffic. forceSSL :: Middleware forceSSL app = \req respond -> if isSecure req then app req respond
Web/App/Middleware/Gzip.hs view
@@ -17,11 +17,10 @@ where import Network.Wai-import Network.Wai.Header import Network.Wai.Internal import Data.Maybe (fromMaybe,isJust) import qualified Codec.Compression.GZip as GZIP (compress)-import qualified Data.ByteString.Char8 as B (ByteString,isInfixOf,break,drop,dropWhile)+import qualified Data.ByteString.Char8 as B (ByteString,readInteger,isInfixOf,break,drop,dropWhile) import Blaze.ByteString.Builder (toLazyByteString) import Blaze.ByteString.Builder.ByteString (fromLazyByteString) @@ -39,6 +38,7 @@ isMSIE6 = fromMaybe False . fmap (B.isInfixOf "MSIE 6") . lookup "User-Agent" . requestHeaders $ env isEncoded = isJust . lookup "Content-Encoding" . responseHeaders isBigEnough = maybe True ((<=) minLen) . contentLength . responseHeaders+ contentLength hdrs = lookup "Content-Length" hdrs >>= fmap fst . B.readInteger -- TODO: ensure original flushing action is eval'd compressResponse :: Response -> (Response -> IO a) -> IO a
− Web/App/Monad.hs
@@ -1,73 +0,0 @@-{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}--{-|-Module : Web.App.Monad-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Definition of 'WebAppM' monad & 'WebAppState' typeclass.--}--module Web.App.Monad-(- -- * Monads- WebAppM(..),- -- * Typeclasses- WebAppState(..),- -- * Cache Operations- getCache,- -- * State Operations- getState,- putState,- modifyState-) where--import Web.App.FileCache (FileCache)-import Web.App.Monad.Internal (WebApp(..))--import Control.Monad.Reader-import Control.Concurrent.STM---- |Defines a common interface for an app's state-class WebAppState s where- -- |Create an app state- initState :: IO s- -- |Destroy an app state- destroyState :: s -- ^ the state to destroy- -> IO ()---- |Monad providing a 'FileCache' and an application state-newtype WebAppM s a = WebAppM { runWebAppM :: ReaderT (TVar (WebApp s)) IO a }- deriving (Functor,Applicative,Monad,MonadIO,MonadReader (TVar (WebApp s)))--liftWebAppM :: (MonadTrans t, WebAppState s) => WebAppM s a -> t (WebAppM s) a-liftWebAppM = lift---- |Get the 'FileCache' embedded in a 'WebAppM' monad-getCache :: (MonadTrans t, WebAppState s) => t (WebAppM s) FileCache-getCache = liftWebAppM $ ask >>= liftIO . fmap webAppCache . readTVarIO---- |Get the state embedded in a 'WebAppM' monad-getState :: (MonadTrans t, WebAppState s) => t (WebAppM s) s-getState = liftWebAppM $ ask >>= liftIO . fmap webAppState . readTVarIO---- |Embed a new state in a 'WebAppM' monad-putState :: (MonadTrans t, WebAppState s) => s -- ^ state to embed- -> t (WebAppM s) ()-putState st = liftWebAppM $ do- tv <- ask- liftIO $ atomically $ do- (WebApp cache _) <- readTVar tv- writeTVar tv (WebApp cache st)---- |Apply a function to the state embedded in a 'WebAppM' monad-modifyState :: (MonadTrans t, WebAppState s) => (s -> s) -- ^ function to apply to state- -> t (WebAppM s) ()-modifyState f = liftWebAppM $ do- tv <- ask- liftIO $ atomically $ do- (WebApp cache st) <- readTVar tv- writeTVar tv (WebApp cache (f st))
− Web/App/Monad/Internal.hs
@@ -1,14 +0,0 @@-{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-}- -module Web.App.Monad.Internal-(- WebApp(..)-)-where- -import Web.App.FileCache (FileCache)--data WebApp s = WebApp {- webAppCache :: FileCache,- webAppState :: s-}
+ Web/App/Parameter.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings, ViewPatterns #-}++module Web.App.Parameter+(+ Parameter(..)+)+where+ +import GHC.Float (double2Float)+import Data.Maybe+import Data.Word+import Data.Int+import Data.Char+import qualified Data.Text as T (Text)+import qualified Data.Text.Encoding as T (decodeUtf8)+import qualified Data.Text.Lazy as TL (Text)+import qualified Data.Text.Lazy.Encoding as TL (decodeUtf8)+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL (ByteString,fromStrict)+ +class Parameter a where+ maybeRead :: B.ByteString -> Maybe a+ maybeReadList :: B.ByteString -> [a]+ maybeReadList = catMaybes . map maybeRead . B.split ','+ +instance Parameter () where+ maybeRead x+ | B.null x = Just ()+ | otherwise = Nothing+ +instance Parameter Bool where+ maybeRead = f . B.map toLower+ where+ f "true" = Just True+ f "false" = Just False+ f "t" = Just True+ f "f" = Just False+ f "yes" = Just True+ f "no" = Just False+ f "y" = Just True+ f "n" = Just False+ f "on" = Just True -- HTML checkboxes+ f "off" = Just False -- HTML checkboxes+ f _ = Nothing++instance Parameter T.Text where+ maybeRead = Just . T.decodeUtf8+ +instance Parameter TL.Text where+ maybeRead = fmap TL.decodeUtf8 . maybeRead++instance Parameter B.ByteString where+ maybeRead = Just+ +instance Parameter BL.ByteString where+ maybeRead = Just . BL.fromStrict+ +instance Parameter Char where+ maybeRead x+ | B.length x == 1 = Just $ B.head x+ | otherwise = Nothing+ maybeReadList = B.unpack+ +instance (Parameter a) => Parameter [a] where+ maybeRead = Just . maybeReadList+ +instance Parameter Double where+ maybeRead "" = Nothing+ maybeRead (B.uncons -> Just ('-',xs)) = negate <$> maybeRead xs+ maybeRead (B.uncons -> Just ('.',v)) = (*) e <$> v''+ where v' = B.takeWhile isDigit v+ v'' = fromIntegral . fst <$> B.readInt v'+ e = 10**(negate $ fromIntegral $ B.length v')+ maybeRead x = (+) (fromMaybe 0 $ maybeRead xs) <$> x''+ where (x',xs) = B.span isDigit x+ x'' = fromInteger . fst <$> B.readInteger x'++instance Parameter Float where+ maybeRead = fmap double2Float . maybeRead++instance Parameter Integer where+ maybeRead = fmap fst . B.readInteger++instance Parameter Int where+ maybeRead = fmap fst . B.readInt++instance Parameter Int8 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Int16 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Int32 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Int64 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger++instance Parameter Word where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word8 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word16 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word32 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger+ +instance Parameter Word64 where+ maybeRead = fmap (fromInteger . fst) . B.readInteger
+ Web/App/Path.hs view
@@ -0,0 +1,129 @@+{-|+Module : Web.App.Path+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++A URI pathInfo wrapper.+-}++{-# LANGUAGE OverloadedStrings #-}++module Web.App.Path+(+ -- * Types+ Path,+ PathInfo,+ -- * Path Constructors+ literal,+ captured,+ regex,+ -- * Path Operations+ pathMatches,+ -- * Text-Based Path Operations+ isRoot,+ splitPath,+ mkPathInfo,+ joinPath,+ pathCaptures+)+where++import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString as B+import Text.Regex.Posix+import Data.List+import Data.String++-- |Represents a PathInfo (e.g. from WAI)+type PathInfo = [Text]++-- |Describes a matchable path.+data Path = LiteralPath PathInfo -- ^ Match a path as-is+ | CapturedPath PathInfo -- ^ Match a path with wildcards+ | RegexPath Regex -- ^ Match a path with a regex+ +instance IsString Path where+ fromString = f . mkPathInfo . T.pack+ where f pinfo = case find (T.isPrefixOf ":") pinfo of+ Just _ -> CapturedPath pinfo+ Nothing -> LiteralPath pinfo+ +-- |Construct a literal 'Path'.+literal :: Text -> Path+literal = LiteralPath . mkPathInfo++-- |Construct a captured 'Path'.+captured :: Text -> Path+captured = CapturedPath . mkPathInfo++-- |Construct a regex 'Path'.+regex :: Text -> Path+regex = RegexPath . makeRegex . T.encodeUtf8++-- |Returns @True@ if the given 'Path' matches the given 'PathInfo'+pathMatches :: Path -> PathInfo -> Bool+pathMatches (RegexPath ex) pin = matchTest ex $ T.encodeUtf8 $ joinPath pin+pathMatches (LiteralPath pin) pin2 = pin == pin2+pathMatches (CapturedPath pin) pin2 = f pin pin2+ where f [] [] = True+ f _ [] = False+ f [] _ = False+ f (c:cs) (p:ps)+ | T.head c == ':' = f cs ps+ | p == c = f cs ps+ | otherwise = False++-- |Returns true if given path is the root.+isRoot :: Path -> Bool+isRoot (RegexPath ex) = matchTest ex ("/" :: String)+isRoot (LiteralPath pin) = null pin+isRoot (CapturedPath pin) = null pin++{- General path operations -}++-- |Splits path into (path,queryString).+splitPath :: Text -- ^ path+ -> (Text,Text)+splitPath pth = (p,T.drop 1 q)+ where (p,q) = T.break (== '?') pth++-- |Split @path@ into a pathInfo list.+mkPathInfo :: Text -- ^ path+ -> PathInfo+mkPathInfo = filter (not . T.null) . T.splitOn "/" . fst . splitPath++-- |Join pathInfo into a 'Text'ual path.+joinPath :: PathInfo -- ^ pathInfo+ -> Text+joinPath = mconcat . (:) "/" . intersperse "/"++{- Captures & Regex Captures -}+ +-- |Returns path captures by comparing @path@ to @pathInfo@.+pathCaptures :: Path -- ^ path+ -> PathInfo -- ^ pathInfo+ -> [(Text,Text)]+pathCaptures (LiteralPath _) _ = []+pathCaptures (RegexPath r) pin = maybe [] (\(_,x,_,xs) -> f (x:xs)) matched+ where+ f = numberList . map T.decodeUtf8+ matched :: Maybe (B.ByteString,B.ByteString,B.ByteString,[B.ByteString])+ matched = matchM r $ T.encodeUtf8 $ joinPath pin++pathCaptures (CapturedPath cap) pin = f [] cap pin+ where+ f acc [] [] = acc+ f _ _ [] = []+ f _ [] _ = []+ f acc (c:cs) (p:ps)+ | T.head c == ':' = f ((T.tail c,p):acc) cs ps+ | p == c = f acc cs ps+ | otherwise = []+ +numberList :: [Text] -> [(Text,Text)]+numberList = zipWith (\a b -> (T.pack $ show a, b)) ([0..] :: [Integer])
− Web/App/Privileges.hs
@@ -1,38 +0,0 @@-{-|-Module : Web.App.Privileges-Copyright : (c) Nathaniel Symer, 2015-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Determine when the process is being ran as root.--}--module Web.App.Privileges-(- isPrivileged,- whenPrivileged,- resignPrivileges-)-where--import Control.Monad-import System.Posix---- | Determine if the process is being ran as root-isPrivileged :: IO Bool-isPrivileged = ((==) 0) <$> getEffectiveUserID---- | Perform an action when ran as root-whenPrivileged :: IO () -- ^ The action to be performed- -> IO ()-whenPrivileged act = do- privileged <- isPrivileged- when privileged act- --- | Drop root privileges-resignPrivileges :: String -- ^ Name of user to "become"- -> IO ()-resignPrivileges user = whenPrivileged $ do- getUserEntryForName user >>= setUserID . userID
+ Web/App/RouteT.hs view
@@ -0,0 +1,311 @@+{-|+Module : Web.App.Monad.WebAppT+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Defines a monad transformer used for defining routes+and using middleware.+-}++{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleInstances, MultiParamTypeClasses #-}++module Web.App.RouteT+(+ -- * RouteT monad transformer+ RouteT,+ evalRouteT,+ -- * Routes+ RouteResult,+ Predicate,+ Route,+ RouteInterrupt(..),+ findRoute,+ -- * Monadic actions+ halt,+ halt',+ next,+ writeBody,+ writeBodyBytes,+ writeJSON,+ request,+ addHeader,+ status,+ headers,+ header,+ redirect,+ params,+ param,+ maybeParam,+ bodyReader,+ body,+ urlencodedBody,+ path+)+where+ +{-++TODO++ * Rewite 'param' and 'maybeParam' to avoid calling next+ * Allow 'InterruptNext' to carry state into+ the evaluation of the next route.+ +-}+ +import Web.App.State+import Web.App.Path+import Web.App.Stream+import Web.App.Parameter+ +import Control.Monad (ap)+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.State.Class+import Control.Monad.Writer.Class+import Control.Concurrent.STM+import Control.Applicative++import Network.Wai+import Network.HTTP.Types.Status+import Network.HTTP.Types.Header+import Network.HTTP.Types.URI++import Data.Maybe+import Data.Monoid+import Data.Aeson+import Data.CaseInsensitive (mk)++import System.IO.Unsafe++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Lazy.Internal as BL (ByteString(Empty,Chunk))+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text.Encoding as T++type Predicate = Request -> Bool -- ^ Used to determine if a route can handle a request+type Route s m = (Predicate, Path, RouteT s m ()) +type RouteResult = Maybe (Status, ResponseHeaders, Stream) -- kind of like a Ruby Rack response.++data RouteInterrupt = InterruptNext -- ^ halt current route evaluation and start evaluating next route+ | InterruptHalt (Maybe Status) ResponseHeaders (Maybe Stream) -- ^ halt & provide a response++-- |Monad transformer in which routes are evaluated. It's essentially+-- an ExceptT crossed with an RWST with the path, body, and push func+-- as the "Reader" state, the response as the "Writer" state, and no+-- "State" state.+newtype RouteT s m a = RouteT {+ runRouteT :: TVar s -- ^ tvar containing state+ -> Path -- ^ path of route+ -> TVar BL.ByteString -- ^ request body+ -> Request -- ^ request being served+ -> m (Either RouteInterrupt (a, Maybe Status, ResponseHeaders, Maybe Stream))+}++-- |Evaluate a 'RouteT' action into a 'RouteResult'.+evalRouteT :: (WebAppState s, MonadIO m)+ => RouteT s m () -- ^ route to evaluate+ -> TVar s -- ^ tvar containing state+ -> Path -- ^ path of route+ -> Request -- ^ request being served+ -> m (RouteResult)+evalRouteT act st pth req = do+ bdy <- liftIO $ newTVarIO BL.Empty+ f <$> runRouteT act st pth bdy req+ where+ f (Left InterruptNext) = Nothing+ f (Left (InterruptHalt s h b)) = Just (fromMaybe status200 s,h,maybe mempty flush b)+ f (Right ~(_,s,h,b)) = Just (fromMaybe status200 s,h,maybe mempty flush b)+ +instance (WebAppState s, Functor m) => Functor (RouteT s m) where+ fmap f m = RouteT $ \st pth bdy req -> fmap apply $ runRouteT m st pth bdy req+ where+ apply (Right (a,s,h,b)) = Right (f a,s,h,b)+ apply (Left e) = Left e+ +instance (WebAppState s, Monad m) => Applicative (RouteT s m) where+ pure a = RouteT $ \_ _ _ _ -> return $ Right (a,Nothing,[],Nothing)+ (<*>) = ap++instance (WebAppState s, Monad m) => Monad (RouteT s m) where+ fail msg = RouteT $ \_ _ _ _ -> fail msg+ m >>= k = RouteT $ \st pth bdy req -> do+ v <- runRouteT m st pth bdy req+ case v of+ Left e -> return $ Left e+ Right ~(x, s, h, b) -> do+ v' <- runRouteT (k x) st pth bdy req+ case v' of+ Left InterruptNext -> return $ Left InterruptNext+ Left (InterruptHalt s' h' b') -> return $ Left combined+ where combined = InterruptHalt (s' <|> s) (h' <> h) (b <> b')+ Right ~(y, s', h', b') -> return $ Right $ combined+ where combined = (y, s' <|> s, h' <> h, b <> b')++instance (WebAppState s) => MonadTrans (RouteT s) where+ lift m = RouteT $ \_ _ _ _ -> m >>= return . Right . (,Nothing,[],Nothing)++instance (WebAppState s, MonadIO m) => MonadIO (RouteT s m) where+ liftIO = lift . liftIO+ +-- |MonadState instance for accessing the mutable state.+instance (WebAppState s, MonadIO m) => MonadState s (RouteT s m) where+ get = RouteT $ \st _ _ _ ->+ Right . (,Nothing,[],Nothing) <$> (liftIO $ readTVarIO st)+ put v = RouteT $ \st _ _ _ ->+ Right . (,Nothing,[],Nothing) <$> (liftIO $ atomically $ writeTVar st v)++-- |MonadWriter instance for writing to the HTTP response body.+instance (WebAppState s, Monad m) => MonadWriter Stream (RouteT s m) where+ tell s = RouteT $ \_ _ _ _ -> return $ Right ((),Nothing,[],Just s)+ listen act = RouteT $ \st pth bdy req -> do+ v <- runRouteT act st pth bdy req+ case v of+ Left e -> return $ Left e+ Right (a,_,_,mw) -> return $ Right ((a,fromMaybe mempty mw),Nothing,[],Nothing)+ pass act = RouteT $ \st pth bdy req -> do+ v <- runRouteT act st pth bdy req+ case v of+ Left e -> return $ Left e+ Right ((a,f),_,_,mw) ->+ return $ Right (a,Nothing,[],maybe mempty (Just . f) mw)++{- Route Evaluation -}++-- |Find the first route that can respond to @request@ in @routes@.+findRoute :: (WebAppState s, Monad m)+ => [Route s m] -- ^ routes+ -> Request -- ^ request+ -> Maybe ([Route s m],Route s m)+findRoute [] _ = Nothing+findRoute (x@(pd,pth,_):xs) req+ | pd req && pathMatches pth (pathInfo req) = Just (xs,x)+ | otherwise = findRoute xs req++{- Monadic actions -}++-- |Halt route evaluation and provide the given 'Status',+-- 'ResponseHeaders', and 'Stream'.+halt :: (WebAppState s, Monad m)+ => Status -- ^ status with which to terminate+ -> ResponseHeaders -- ^ headers with which to terminate+ -> Stream -- ^ body with which to terminate+ -> RouteT s m a+halt s h b = act >> let x = x in x -- second action will never be evaluated+ where act = RouteT $ \_ _ _ _ ->+ return $ Left $ InterruptHalt (Just s) h (Just b)+ +-- |Halt route evaluation and provide the accumulated 'Status',+-- 'ResponseHeaders', and 'Stream'.+halt' :: (WebAppState s, Monad m) => RouteT s m a+halt' = act >> let x = x in x -- second action will never be evaluated+ where act = RouteT $ \_ _ _ _ ->+ return $ Left $ InterruptHalt Nothing [] Nothing++-- |Halt route evaluation and move onto the next+-- route that passes.+next :: (WebAppState s, Monad m) => RouteT s m a+next = act >> let x = x in x -- second action will never be evaluated+ where act = RouteT $ \_ _ _ _ -> return $ Left InterruptNext++-- |Write a 'Stream' to the response body.+writeBody :: (WebAppState s, Monad m, ToStream w) => w -> RouteT s m ()+writeBody w = RouteT $ \_ _ _ _ ->+ return $ Right ((),Nothing,[],Just $ stream w)+ +-- |Same as 'writeBody', but designed for use+-- with literals via OverloadedStrings+writeBodyBytes :: (WebAppState s, Monad m) => ByteString -> RouteT s m ()+writeBodyBytes = writeBody+ +-- |Write a JSON object to the response body.+writeJSON :: (WebAppState s, Monad m, ToJSON j) => j -> RouteT s m ()+writeJSON = writeBody . encode++-- |Get the 'Request' being served.+request :: (WebAppState s, Monad m) => RouteT s m Request+request = RouteT $ \_ _ _ req -> return $ Right (req,Nothing,[],Nothing)++-- |Add an HTTP header.+addHeader :: (WebAppState s, Monad m) => HeaderName -> ByteString -> RouteT s m ()+addHeader k v = RouteT $ \_ _ _ _ -> return $ Right ((),Nothing,[(k,v)],Nothing)++-- |Set the HTTP status.+status :: (WebAppState s, Monad m) => Status -> RouteT s m ()+status s = RouteT $ \_ _ _ _ -> return $ Right ((),Just s,[],Nothing)++-- |Redirect to the given path using a @Location@ header and+-- an HTTP status of 302. Route evaluation continues.+redirect :: (WebAppState s, MonadIO m) => ByteString -> RouteT s m ()+redirect url = halt status302 [("Location",url)] mempty+ +-- |Get the 'Request''s headers.+headers :: (WebAppState s, Monad m) => RouteT s m RequestHeaders+headers = requestHeaders <$> request++-- |Get a specific header.+header :: (WebAppState s, Monad m) => ByteString -> RouteT s m (Maybe ByteString)+header k = lookup (mk k) <$> headers++-- |Get the 'Request''s parameters (in order captures, HTTP body, URI query).+params :: (WebAppState s, MonadIO m) => RouteT s m Query+params = fmap mconcat $ sequence [cap, bdy, q]+ where+ cap = do+ pinfo <- pathInfo <$> request+ pth <- path+ return $ map toQueryItem $ pathCaptures pth pinfo+ where toQueryItem (a,b) = (T.encodeUtf8 a, Just $ T.encodeUtf8 b)+ bdy = do+ h <- requestHeaders <$> request+ case lookup (mk "Content-Type") h of+ Just "application/x-www-form-urlencoded" -> parseQuery . BL.toStrict <$> body+ Just "multipart/form-data" -> return [] -- TODO: implement me+ _ -> return []+ q = queryString <$> request++-- |Get a specific header. Will call 'next' if the parameter isn't present.+param :: (WebAppState s, MonadIO m, Parameter a) => ByteString -> RouteT s m a+param k = maybeParam k >>= maybe next return++-- |Get a specific header. Will not interfere with route evaluation.+maybeParam :: (WebAppState s, MonadIO m, Parameter a) => ByteString -> RouteT s m (Maybe a)+maybeParam k = f . lookup k <$> params+ where f (Just (Just v)) = maybeRead v+ f _ = Nothing++-- |Get an action that reads a chunk from the request body.+-- Incompatible with 'body'.+bodyReader :: (WebAppState s, MonadIO m) => RouteT s m (IO ByteString)+bodyReader = RouteT $ \_ _ _ r -> return $ Right (requestBody r,Nothing,[],Nothing)++-- |Read the request body as a lazy 'ByteString'.+-- Incompatible with 'bodyReader'.+body :: (WebAppState s, MonadIO m) => RouteT s m BL.ByteString+body = do+ tvar <- bodyTVar+ act <- fmap requestBody request+ liftIO $ persisted tvar act+ where+ bodyTVar = RouteT $ \_ _ b _ -> return $ Right (b,Nothing,[],Nothing)+ persisted tvar act = do+ remaining <- lazyRead act+ atomically $ do+ alreadyRead <- readTVar tvar+ writeTVar tvar $ alreadyRead <> remaining+ readTVar tvar+ lazyRead f = unsafeInterleaveIO $ do+ c <- f+ if B.null c+ then return BL.Empty+ else BL.Chunk c <$> (lazyRead f)++urlencodedBody :: (WebAppState s, MonadIO m) => RouteT s m Query+urlencodedBody = parseQuery . BL.toStrict <$> body++path :: (WebAppState s, Monad m) => RouteT s m Path+path = RouteT $ \_ pth _ _ -> return $ Right (pth,Nothing,[],Nothing)
+ Web/App/State.hs view
@@ -0,0 +1,29 @@+{-|+Module : Web.App.State+Copyright : (c) Nathaniel Symer, 2016+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Typeclass all types to be used as state for a WebApp+must have an instance of.+-}++module Web.App.State+(+ WebAppState(..)+)+where+ +-- |Defines a common interface for an app's state.+class WebAppState s where+ -- |Create an app state+ initState :: IO s+ -- |Destroy an app state+ destroyState :: s -- ^ the state to destroy+ -> IO ()+ +instance WebAppState () where+ initState = return ()+ destroyState _ = return ()
+ Web/App/Stream.hs view
@@ -0,0 +1,75 @@+{-|+Module : Web.App.Stream+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++@newtype@ wrapper around a WAI 'StreamingBody'.+-}++{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module Web.App.Stream+(+ Stream(..),+ ToStream(..),+ flush,+ flusher+)+where+ +import Network.Wai (StreamingBody)+import Blaze.ByteString.Builder hiding (flush)+import Blaze.ByteString.Builder.Char8 hiding (fromString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL+import Data.Monoid++-- |An HTTP response body stream.+newtype Stream = Stream { runStream :: StreamingBody }++instance Monoid Stream where+ mempty = Stream $ \_ _ -> return ()+ mappend (Stream a) (Stream b) = Stream $ \w f -> a w f >> b w f++-- |Flush a stream.+flush :: Stream -> Stream+flush s = s <> flusher++-- |A stream that flushes written data.+flusher :: Stream+flusher = Stream $ \_ f -> f++-- |Turn data into a WAI stream.+class ToStream a where+ stream :: a -> Stream++instance (ToStream a) => ToStream [a] where+ stream = mconcat . map stream+ +instance ToStream () where+ stream _ = mempty+ +instance ToStream Builder where+ stream b = Stream $ \w f -> w b >> f++instance ToStream Char where+ stream = stream . fromChar++instance ToStream T.Text where+ stream = stream . T.encodeUtf8++instance ToStream TL.Text where+ stream = stream . TL.encodeUtf8+ +instance ToStream B.ByteString where+ stream = stream . fromByteString+ +instance ToStream BL.ByteString where+ stream = stream . fromLazyByteString
− Web/App/TerminalSize.hsc
@@ -1,61 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--{-|-Module : Web.App.TerminalSize-License : MIT-Maintainer : nate@symer.io-Stability : experimental-Portability : POSIX--Get the size of the terminal. Adapted from http://stackoverflow.com/questions/12806053/get-terminal-width-haskell.--}--module Web.App.TerminalSize-(- -- * Terminal Size- getTermSize-)-where--import Foreign-import Foreign.C.Error-import Foreign.C.Types--import Control.Monad as M (void)--#include <sys/ioctl.h>-#include <unistd.h>---- Trick for calculating alignment of a type, taken from--- http://www.haskell.org/haskellwiki/FFICookBook#Working_with_structs-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)---- @xpixel@ and @ypixel@ fields are unused,--- so they've been omitted.-data WinSize = WinSize CUShort CUShort -- row, col--instance Storable WinSize where- sizeOf _ = (#size struct winsize)- alignment _ = (#alignment struct winsize) - peek ptr = WinSize- <$> (#peek struct winsize, ws_row) ptr- <*> (#peek struct winsize, ws_col) ptr- poke ptr (WinSize row col) = do- (#poke struct winsize, ws_row) ptr row- (#poke struct winsize, ws_col) ptr col--foreign import ccall "sys/ioctl.h ioctl"- ioctl :: CInt -> CInt -> Ptr WinSize -> IO CInt---- | Get the size of the terminal.-getTermSize :: IO (Maybe (Int, Int)) -- ^ @(rows, columns)@-getTermSize = with (WinSize 0 0) $ \ws -> do- resetErrno- M.void $ ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws- err <- getErrno- if isValidErrno err- then do- WinSize row col <- peek ws- return $ Just (fromIntegral row, fromIntegral col)- else return Nothing-
+ Web/App/WebApp.hs view
@@ -0,0 +1,119 @@+{-|+Module : Web.App.Monad.WebAppT+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Defines a monoid used for defining routes+and using middleware.+-}++{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleInstances #-}++module Web.App.WebApp+(+ WebApp(..),+ toApplication,+ -- * Web App Operations+ middleware,+ route,+ get,+ post,+ put,+ patch,+ delete,+ options,+ anyRequest,+ matchAll+) where++import Web.App.State+import Web.App.RouteT+import Web.App.Path+import Web.App.Stream++import Control.Monad.IO.Class+import Control.Concurrent.STM++import Network.Wai+import Network.HTTP.Types.Status+import Network.HTTP.Types.Method++import Data.Monoid++-- |Monoid for defining routes & adding middleware.+newtype WebApp s m = WebApp { runWebApp :: ([Route s m],[Middleware]) }++instance (WebAppState s, Monad m) => Monoid (WebApp s m) where+ mempty = WebApp ([],[])+ mappend (WebApp (r,mw)) (WebApp (r',mw')) = WebApp (r <> r',mw <> mw')++-- |Turn a 'WebAppT' computation into a WAI 'Application'.+toApplication :: (WebAppState s, MonadIO m, MonadIO n)+ => (m RouteResult -> IO RouteResult) -- ^ fnc eval a monadic computation in @m@ in @IO@+ -> WebApp s m -- ^ a web app+ -> n (Application, -- ^ WAI application+ IO ()) -- ^ teardown action; call when shutting down app server+toApplication runToIO webapp = do+ st <- liftIO $ newTVarIO =<< initState+ let (rts,mws) = runWebApp webapp+ app = foldl (flip ($)) (mkApp st rts) mws+ teardown = readTVarIO st >>= destroyState+ return (app, teardown)+ where+ plainText = [("Content-Type", "text/plain; charset=utf-8")]+ mkApp tvar routes req callback = case findRoute routes req of+ Nothing -> callback $ responseLBS status404 plainText "Not found."+ Just (remainder,(_,pth,act)) -> do+ res <- runToIO $ evalRouteT act tvar pth req+ case res of+ Nothing -> mkApp tvar remainder req callback+ Just (s,h,b) -> callback $ responseStream s h $ runStream b++-- |Use a middleware+middleware :: (WebAppState s, Monad m) => Middleware -> WebApp s m+middleware m = WebApp ([],[m])++-- |Define a route+route :: (WebAppState s, Monad m) => Predicate -> Path -> RouteT s m () -> WebApp s m+route p pth act = WebApp ([(p,pth,act)],[])++{-# INLINE matchMethod #-}+matchMethod :: Method -> Predicate+matchMethod meth = \r -> (requestMethod r) == meth++{- Monadic matchers -}++-- |Match a `GET` request.+get :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+get p act = route (matchMethod methodGet) p act++-- |Match a `POST` request.+post :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+post p act = route (matchMethod methodPost) p act++-- |Match a `PUT` request.+put :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+put p act = route (matchMethod methodPut) p act++-- |Match a `PATCH` request.+patch :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+patch p act = route (matchMethod methodPatch) p act++-- |Match a `DELETE` request.+delete :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+delete p act = route (matchMethod methodDelete) p act++-- |Match a `OPTIONS` request.+options :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+options p act = route (matchMethod methodOptions) p act++-- |Match any request given a path.+anyRequest :: (WebAppState s, Monad m) => Path -> RouteT s m () -> WebApp s m+anyRequest = route (const True)++-- |Match all requests and paths.+matchAll :: (WebAppState s, Monad m) => RouteT s m () -> WebApp s m+matchAll = route (const True) (regex ".*")
webapp.cabal view
@@ -1,6 +1,6 @@ Name: webapp-Version: 0.1.2-Synopsis: Haskell web scaffolding using Scotty, WAI, and Warp+Version: 0.2.0+Synopsis: Haskell web app framework based on WAI & Warp Homepage: https://github.com/fhsjaagshs/webapp Bug-reports: https://github.com/fhsjaagshs/webapp/issues License: MIT@@ -14,60 +14,48 @@ Cabal-version: >= 1.10 Description: See README.md -Extra-source-files:- README.md- CHANGELOG.md+Extra-source-files: README.md CHANGELOG.md Library- build-tools: hsc2hs, happy >= 1.19, alex >= 3.1.4+ build-tools: hsc2hs ghc-options: -Wall Exposed-modules: Web.App- Web.App.Assets- Web.App.Cookie- Web.App.FileCache Web.App.HTTP- Web.App.IO- Web.App.Monad+ Web.App.State Web.App.Middleware Web.App.Middleware.Gzip Web.App.Middleware.ForceSSL- other-modules: Web.App.Daemon- Web.App.Privileges- Web.App.TerminalSize- Web.App.Monad.Internal+ Web.App.Parameter+ Web.App.Path+ Web.App.RouteT+ Web.App.Stream+ Web.App.Main+ Web.App.Internal.TerminalSize+ Web.App.WebApp+ other-modules: Web.App.Internal.IO+ Web.App.Internal.Daemon+ Web.App.Internal.Privileges default-language: Haskell2010 build-depends: base >= 4.8.0.0 && <= 4.8.1.0,+ bytestring,+ base16-bytestring,+ text, mtl, stm, transformers,- scotty, wai,- wai-extra, warp, warp-tls, network, streaming-commons,+ regex-posix, http-types,- bytestring,- data-default,- time,- unordered-containers,- attoparsec, unix,- fsnotify,- filepath,- hashtables,- base16-bytestring, blaze-builder, zlib,- cryptohash,- text,- hjsmin,- css-text,- mime-types,- filepath,- directory,- optparse-applicative+ optparse-applicative,+ aeson,+ case-insensitive source-repository head type: git