webapp (empty) → 0.0.1
raw patch · 16 files changed
+1087/−0 lines, 16 filesdep +attoparsecdep +basedep +base16-bytestringsetup-changed
Dependencies added: attoparsec, base, base16-bytestring, bcrypt, blaze-builder, bytestring, cryptohash, css-text, data-default, directory, filepath, fsnotify, hashtables, hjsmin, http-types, mime-types, mtl, optparse-applicative, scotty, stm, text, time, transformers, unix, unordered-containers, wai, wai-extra, warp, warp-tls, zlib
Files
- LICENSE +19/−0
- README.md +30/−0
- Setup.hs +2/−0
- Web/App.hs +120/−0
- Web/App/Assets.hs +78/−0
- Web/App/Cookie.hs +66/−0
- Web/App/Daemon.hs +99/−0
- Web/App/FileCache.hs +159/−0
- Web/App/Gzip.hs +59/−0
- Web/App/HTTP.hs +117/−0
- Web/App/IO.hs +66/−0
- Web/App/Monad.hs +73/−0
- Web/App/Password.hs +29/−0
- Web/App/Privileges.hs +38/−0
- Web/App/TerminalSize.hsc +61/−0
- webapp.cabal +71/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2015 Nathaniel Symer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ README.md view
@@ -0,0 +1,30 @@+# webapp - simple webapp scaffolding with state++Basic example:++ module Main where+ + import Web.App+ import Web.Scotty.Trans+ + instance WebAppState Integer where+ initState = return 0+ destroyState st = do+ putStr "Counted: "+ print st++ main = webappMain app "My Web App" "This is a demo web app"++ app :: (ScottyError e) => ScottyT e (WebAppM Integer) ()+ app = do+ get "/add" $ do+ modifyState (+1)+ + 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Web/App.hs view
@@ -0,0 +1,120 @@+{-|+Module : Web.App+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Root modules 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.Password,+ module Web.App.IO,+ module Web.App.Monad+)+where++import Web.App.Assets+import Web.App.Cookie+import Web.App.Daemon+import Web.App.FileCache+import Web.App.HTTP+import Web.App.Password+import Web.App.IO+import Web.App.Monad+import Web.App.TerminalSize++import Control.Applicative+import Options.Applicative+import System.Environment (getArgs)+import Web.Scotty.Trans (ScottyT,ScottyError)+import System.IO++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+ }+ | PasswordCommand {+ _passwordCmdPassword :: String+ }++-- | Read commandline arguments and start app accordingly.+webappMain :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ app to start+ -> String -- ^ CLI title+ -> String -- ^ CLI description+ -> IO ()+webappMain app title desc = getArgs >>= getCommandArgs title desc >>= f+ where+ 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+ f (PasswordCommand pwd) = hashPassword pwd >>= g+ where+ g (Just v) = putStrLn v+ g Nothing = hPutStrLn stderr "failed to hash password"+ showStatus True = "running"+ showStatus False = "stopped"++getCommandArgs :: String -> String -> [String] -> IO Cmd+getCommandArgs title desc args = do+ w <- maybe 80 snd <$> getTermSize+ handleParseResult $ execParserPure (pprefs w) parser args+ where+ pprefs = ParserPrefs "" False False True+ parser = info (helper <*> parseCommand) (fullDesc <> progDesc desc <> header title)+ +parseCommand :: Parser Cmd+parseCommand = sp <|> parseStart+ where+ sp = subparser $ (mkcmd "start" "Start the application server" parseStart) <>+ (mkcmd "stop" "Stop the application server" parseStop) <>+ (mkcmd "status" "Determine if the application server is running" parseStatus) <>+ (mkcmd "password" "Make a BCrypt hash from a password" parseHash)+ parseStart = 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 = StopCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")+ parseStatus = StatusCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")+ parseHash = PasswordCommand <$> (strArgument $ metavar "PASSWORD" <> help "password to hash")+ 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/Assets.hs view
@@ -0,0 +1,78 @@+{-# 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 view
@@ -0,0 +1,66 @@+{-# 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 view
@@ -0,0 +1,99 @@+{-|+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+)+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 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++-- |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++{- Internal -}++-- 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++pidWrite :: FilePath -> IO ()+pidWrite pidPath = getProcessID >>= writeFile pidPath . show++pidRead :: FilePath -> IO (Maybe CPid)+pidRead pidFile = fileExist pidFile >>= f where+ f True = fmap (Just . read) . readFile $ pidFile+ f False = return Nothing++pidLive :: CPid -> IO Bool+pidLive pid = (getProcessPriority pid >> return True) `catch` f where+ f :: IOException -> IO Bool+ f _ = return False
+ Web/App/FileCache.hs view
@@ -0,0 +1,159 @@+{-# 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/Gzip.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+{-|+Module : Web.App.Gzip+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : Cross-Platform++WAI middleware to GZIP HTTP responses.+-}++module Web.App.Gzip+(+ gzip+)+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 Blaze.ByteString.Builder (toLazyByteString)+import Blaze.ByteString.Builder.ByteString (fromLazyByteString)++-- | Creates a 'Middleware' that GZIPs HTTP responses+gzip :: Integer -- ^ Minimum response length that's GZIP'd+ -> Middleware+gzip minLen app env sendResponse = app env f+ where+ f res@ResponseRaw{} = sendResponse res+ f res+ | isCompressable res = compressResponse res sendResponse+ | otherwise = sendResponse res+ isCompressable res = isAccepted && not isMSIE6 && (not $ isEncoded res) && isBigEnough res+ isAccepted = fromMaybe False . fmap acceptsGZIP . lookup "Accept-Encoding" . requestHeaders $ env+ 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++-- TODO: ensure original flushing action is eval'd+compressResponse :: Response -> (Response -> IO a) -> IO a+compressResponse res sendResponse = f $ lookup "Content-Type" hs+ where+ (s,hs,wb) = responseToStream res+ hs' = (++) [("Vary","Accept-Encoding"),("Content-Encoding","gzip")] . filter ((/=) "Content-Length" . fst) $ hs+ f (Just _) = wb $ \b -> sendResponse $ responseStream s hs' $ \w fl -> b (writeCompressed w) fl+ f _ = sendResponse res+ writeCompressed w = w . fromLazyByteString . GZIP.compress . toLazyByteString++acceptsGZIP :: B.ByteString -> Bool+acceptsGZIP "" = False+acceptsGZIP x = if y == "gzip"+ then True+ else acceptsGZIP $ skipSpace z+ where (y,z) = B.break (== ',') x+ skipSpace = B.dropWhile (== ' ') . B.drop 1
+ Web/App/HTTP.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Web.App.HTTP+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Start an HTTP server.+-}++module Web.App.HTTP+(+ -- * Insecure HTTP+ startHTTP,+ -- * Secure HTTPS+ startHTTPS+)+where++import Web.App.Monad+import Web.App.Monad.Internal+import Web.App.IO+import Web.App.FileCache+import Web.App.Gzip+import Web.App.Privileges++import Data.Maybe+import Control.Monad+import Control.Monad.Reader (runReaderT)+import Control.Concurrent.STM++import Web.Scotty.Trans as Scotty++import Network.Wai (responseLBS,requestHeaderHost,rawPathInfo,rawQueryString,Application)+import Network.Wai.HTTP2 (promoteApplication,HTTP2Application)+import Network.Wai.Handler.Warp (defaultSettings,setPort,setBeforeMainLoop,setInstallShutdownHandler,runHTTP2Settings,Settings)+import Network.Wai.Handler.WarpTLS (certFile,defaultTlsSettings,keyFile,runHTTP2TLS)+import Network.HTTP.Types.Status (status301)+import Network.Wai.Middleware.AddHeaders++import System.Exit+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 = do+ (wai,wai2,webapp) <- mkApplication app False+ runHTTP2Settings (mkWarpSettings port webapp) wai2 wai++-- |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+ whenPrivileged startRedirectProcess+ (wai,wai2,webapp) <- mkApplication app True+ runHTTP2TLS tlssettings (mkWarpSettings port webapp) wai2 wai+ where tlssettings = defaultTlsSettings { keyFile = key, certFile = cert }++{- Internal -}++mkWarpSettings :: (WebAppState s) => Int -> WebApp s -> Settings+mkWarpSettings port (WebApp cache st) = setBeforeMainLoop before+ $ setInstallShutdownHandler shutdown+ $ setPort port+ defaultSettings+ where+ before = resignPrivileges "daemon"+ shutdown act = do+ void $ act+ teardownFileCache cache+ destroyState st+ +mkApplication :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -> Bool -> IO (Application, HTTP2Application, WebApp s)+mkApplication app ssl = do+ webapp <- WebApp <$> (newFileCache "assets/") <*> initState+ sync <- newTVarIO webapp+ let runActionToIO m = runReaderT (runWebAppM m) sync+ wai <- scottyAppT runActionToIO $ do+ middleware $ gzip 860 -- min length to GZIP+ when ssl $ middleware $ addHeaders [("Strict-Transport-Security","max-age=31536000")]+ app+ return (wai, promoteApplication wai, webapp)++startRedirectProcess :: IO ()+startRedirectProcess = void $ do+ putStrLn "starting HTTP -> HTTPS process"+ -- TODO: improve separation from parent process+ pid <- forkProcess $ do+ redirectStdout $ Just "/dev/null"+ redirectStderr $ Just "/dev/null"+ redirectStdin $ Just "/dev/null"+ void $ installHandler sigTERM (Catch childHandler) Nothing+ runHTTP2Settings warpSettings (promoteApplication app) app+ + void $ installHandler sigTERM (Catch $ parentHandler pid) Nothing+ void $ installHandler sigINT (Catch $ parentHandler pid) Nothing+ where+ warpSettings = setBeforeMainLoop (resignPrivileges "daemon") $ setPort 80 defaultSettings+ mkHeaders r = [("Location", url r)]+ host = fromJust . requestHeaderHost+ url r = mconcat ["https://", host r, rawPathInfo r, rawQueryString r]+ childHandler = exitImmediately ExitSuccess+ parentHandler pid = do+ putStrLn "killing HTTP -> HTTPS process"+ signalProcess sigTERM pid+ exitImmediately ExitSuccess+ app req respond = respond $ responseLBS status301 (mkHeaders req) ""+
+ Web/App/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.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/Monad.hs view
@@ -0,0 +1,73 @@+{-# 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/Password.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Web.App.Password+Copyright : (c) Nathaniel Symer, 2015+License : MIT+Maintainer : nate@symer.io+Stability : experimental+Portability : POSIX++Generate BCrypt hashes.+-}++module Web.App.Password+(+ -- * Password Hashing+ hashPassword+)+where++import Crypto.BCrypt hiding (hashPassword)+import qualified Data.ByteString.Char8 as B (pack,unpack)++-- | Hash a password with the most strict 'HashingPolicy'+hashPassword :: String -- ^ Password to hash+ -> IO (Maybe String)+hashPassword pwd = do+ hsh <- hashPasswordUsingPolicy (HashingPolicy 12 "$2b$") (B.pack pwd)+ return $ fmap B.unpack hsh
+ Web/App/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.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/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.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+
+ webapp.cabal view
@@ -0,0 +1,71 @@+Name: webapp+Version: 0.0.1+Synopsis: Haskell web scaffolding using Scotty, WAI, and Warp+Homepage: https://github.com/fhsjaagshs/webapp+Bug-reports: https://github.com/fhsjaagshs/webapp/issues+License: MIT+License-file: LICENSE+Author: Nathaniel Symer <nate@symer.io>+Maintainer: Nathaniel Symer <nate@symer.io>+Copyright: (c) 2015 Nathaniel Symer+Category: Web+Stability: experimental+Build-type: Simple+Cabal-version: >= 1.10+Description: See README.md++Extra-source-files:+ README.md++Library+ build-tools: hsc2hs+ other-modules: Web.App.TerminalSize+ ghc-options: -Wall -O2+ Exposed-modules: Web.App+ Web.App.Assets+ Web.App.Cookie+ Web.App.Daemon+ Web.App.FileCache+ Web.App.HTTP+ Web.App.Password+ Web.App.IO+ Web.App.Monad+ other-modules: Web.App.Gzip+ Web.App.Privileges+ Web.App.TerminalSize+ default-language: Haskell2010+ build-depends: base >= 4.8.0.0 && <= 4.8.1.0,+ mtl,+ stm,+ transformers,+ scotty,+ wai,+ wai-extra,+ warp,+ warp-tls,+ 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,+ bcrypt,+ filepath,+ directory,+ optparse-applicative++source-repository head+ type: git+ location: git://github.com/fhsjaagshs/webapp.git