packages feed

seacat (empty) → 1.0.0.0

raw patch · 11 files changed

+1150/−0 lines, 11 filesdep +ConfigFiledep +MissingHdep +basesetup-changed

Dependencies added: ConfigFile, MissingH, base, blaze-builder, blaze-html, bytestring, data-default, directory, filepath, http-types, mime-types, monad-control, mtl, network, persistent, persistent-postgresql, persistent-sqlite, persistent-template, text, time, transformers, wai, wai-extra, wai-middleware-static, warp, web-routes

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ seacat.cabal view
@@ -0,0 +1,111 @@+-- Initial seacat.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                seacat++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             1.0.0.0++-- A short (one-line) description of the package.+synopsis:            Small web framework using Warp and WAI++-- A longer description of the package.+description:+  A small Haskell web framework using Warp and WAI that tries to get+  out of your way and let you do what you want, but also providing+  more advanced features like rate limiting and flood protection.+  .+  [WAI] <http://hackage.haskell.org/package/wai>+  .+  [Warp] <http://hackage.haskell.org/package/warp>++-- URL for the project homepage or repository.+homepage:            https://github.com/Barrucadu/lambdadelta++-- The license under which the package is released.+license:             OtherLicense++-- The file containing the license text.+license-file:        ../LICENSE++-- The package author(s).+author:              Michael Walker++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          mike@barrucadu.co.uk++-- A copyright notice.+-- copyright:           ++category:            Web++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+-- extra-source-files:  ++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10+++library+  -- Modules exported by the library.+  exposed-modules:     Web.Seacat+                     , Web.Seacat.Configuration+                     , Web.Seacat.RequestHandler+                     , Web.Seacat.RequestHandler.BanHammer+                     , Web.Seacat.RequestHandler.OnMethod+  +  -- Modules included in this library but not exported.+  other-modules:       Web.Seacat.Database+                     , Web.Seacat.Server+                     , Web.Seacat.RequestHandler.Types+                     , Web.Seacat.Router+  +  ghc-options: -Wall  ++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:    +  +  -- Other library packages from which modules are imported.+  build-depends:       base >=4.7 && <4.8+                     , blaze-builder >=0.3 && <0.4+                     , blaze-html >=0.7 && <0.8+                     , bytestring >=0.10 && <0.11+                     , ConfigFile >=1.1 && <1.2+                     , data-default >= 0.5 && <0.6+                     , directory >=1.2 && <1.3+                     , filepath >=1.3 && <1.4+                     , http-types >=0.8 && <0.9+                     , mime-types >=0.1 && <0.2+                     , MissingH >=1.2 && <1.3+                     , monad-control >=0.3 && <0.4+                     , mtl >=2.1 && <2.2+                     , network >=2.5 && <2.6+                     , persistent >=1.3 && <1.4+                     , persistent-postgresql >=1.3 && <1.4+                     , persistent-sqlite >=1.3 && <1.4+                     , persistent-template >=1.3 && <1.4+                     , text >=1.1 && <1.2+                     , time >=1.4 && <1.5+                     , transformers >=0.3 && <0.5+                     , wai >=3.0 && <3.1+                     , wai-extra >=3.0 && <3.1+                     , wai-middleware-static >=0.6 && <0.7+                     , warp >=3.0 && <3.1+                     , web-routes >=0.27 && <0.28++  -- Directories containing source files.+  hs-source-dirs:      src+  +  -- Base language which the package is written in.+  default-language:    Haskell2010+
+ src/Web/Seacat.hs view
@@ -0,0 +1,56 @@+-- |The entry point of the Seacat module hierarchy: this module+-- re-exports many common functions and types from the rest of the+-- library, and submodules of this comprise all Seacat functionality.+module Web.Seacat+    ( -- * Types from dependencies, re-exported for convenience.+      FileInfo(..)+    , PathInfo(..)+    , ConfigParser(..)++    -- * Running the server+    , SeacatSettings(..)+    , defaultSettings+    , seacat++    -- * Request handler types+    , Cry(..)+    , MkUrl+    , RequestProcessor+    , Handler++    -- * Request handler utilities+    , askCry+    , askConf+    , askMkUrl+    , askReq++    -- * Configuration accessors+    , get+    , get'+    , conf+    , conf'++    -- * Response builders+    , htmlResponse+    , htmlResponse'+    , textResponse+    , textResponse'+    , respondFile+    , redirect++    -- * Parameter accessors+    , param+    , param'+    , hasParam+    , params++    -- * File upload handling+    , files+    , save+    , save'+    ) where++import Web.Seacat.Configuration+import Web.Seacat.Server+import Web.Seacat.RequestHandler+import Web.Seacat.RequestHandler.Types
+ src/Web/Seacat/Configuration.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleContexts #-}++-- |Configuration file handling. This module re-exports `ConfgParser`+-- and `get` from `Data.ConfigFile`, as pretty much all applications+-- will want to use those in conjunction with this module.+module Web.Seacat.Configuration ( ConfigParser+                                , loadConfigFile+                                , reloadConfigFile+                                , applyUserConfig+                                , defaults+                                , get+                                , get'+                                , conf+                                , conf') where++import Control.Applicative ((<$>))+import Control.Monad.Error.Class (MonadError)+import Data.ConfigFile+import Data.Either.Utils (forceEither)+import System.IO.Error (catchIOError)+import Web.Routes.PathInfo (PathInfo)+import Web.Seacat.RequestHandler.Types (RequestProcessor, askConf)++-- |Load a configuration file by name.+-- All errors (syntax, file access, etc) are squashed together,+-- returning a Nothing if anything fails. This is probably ok, given+-- the simplicity of the format, however it may be useful later on to+-- distinguish between syntax errors (and where they are) and access+-- errors, giving the user a better error message than just "oops,+-- something went wrong"+--+-- String interpolation is turned on (with a depth of 10). See the+-- `Data.ConfigParser` documentation for details on that.+--+-- This sets all of the configuration values expected by the main+-- application to their defaults if they weren't present already, but+-- other values are left as they are in the file.+loadConfigFile :: FilePath -> IO (Maybe ConfigParser)+loadConfigFile filename = (Just <$> loadConfigFileUnsafe filename) `catchIOError` const (return Nothing)++-- |Load a configuration file unsafely. This may throw an IO+-- exception.+loadConfigFileUnsafe :: FilePath -> IO ConfigParser+loadConfigFileUnsafe filename = do+  let base = emptyCP { accessfunc = interpolatingAccess 10 }+  cp <- readfile base filename+  return . merge defaults $ forceEither cp++-- |Reload and reapply the configuration file. If an error is raised,+-- fall back to the original configuration. Specifically, this merges+-- the new configuration with the old, so if the new configuration has+-- removed a required setting, this won't cause a problem.+reloadConfigFile :: ConfigParser    -- ^ The original configuration+                 -> FilePath        -- ^ The config file to load+                 -> IO ConfigParser -- ^ The new configuration+reloadConfigFile cfg filename = ((cfg `merge`) <$> loadConfigFileUnsafe filename) `catchIOError` const (return cfg)++-- |Default configuration values:+--+-- - Listen on *:3000+-- - Use http://localhost:3000 as the basis for all URLs+-- - Use /tmp as the basis for all file look-ups+-- - Use a sqlite database called seacat.sqlite with 10 connections.++defaults :: ConfigParser+defaults = forceEither . readstring emptyCP $ unlines+  [ "[server]"+  , "host      = *"+  , "port      = 3000"+  , "web_root  = http://localhost:3000"+  , "file_root = /tmp"+  , "[database]"+  , "backend           = sqlite"+  , "connection_string = seacat.sqlite"+  , "pool_size         = 10"+  ]++-- |Apply the supplied configuration to the standard+-- configuration. This overrides the values in the original+-- configuration with the ones in the user configuration, if provided,+-- preserving any missing values.+applyUserConfig :: ConfigParser       -- ^ The standard configuration+                -> Maybe ConfigParser -- ^ Optional application-specific configuration+                -> ConfigParser+applyUserConfig cfg (Just usercfg) = cfg `merge` usercfg+applyUserConfig cfg _ = cfg++-- |Get a value from the configuration unsafely (throws an+-- `IOException` on fail).+get' :: Get_C a => ConfigParser -> SectionSpec -> OptionSpec -> a+get' cp ss os = forceEither $ get cp ss os++-- |Get a value from the configuration in a handler. I found as I was+-- using Seacat that my handlers all started with a block of the form,+--+-- > cfg <- askConf+-- > let foo = get cfg "section" "foo"+-- > let bar = get cfg "section" "bar"+-- > let baz = get cfg "section" "baz"+--+-- This simplifies that by getting rid of the need to use `askConf`+-- manually.+conf :: (Get_C a, MonadError CPError m, PathInfo r) => SectionSpec -> OptionSpec -> RequestProcessor r (m a)+conf ss os = askConf >>= \config -> return $ get config ss os++-- |Get a value from the configuration in a handler unsafely. Like+-- `conf`, but throws an `IOException` if the value can't be found.+conf' :: (Get_C a, PathInfo r) => SectionSpec -> OptionSpec -> RequestProcessor r a+conf' ss os = askConf >>= \config -> return $ get' config ss os
+ src/Web/Seacat/Database.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE FlexibleContexts, GADTs, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}++module Web.Seacat.Database where++import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.String (IsString, fromString)+import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8)+import Data.Time (UTCTime)+import Database.Persist.Postgresql (withPostgresqlPool)+import Database.Persist.Sql (ConnectionPool, SqlPersistM, runSqlPersistMPool)+import Database.Persist.Sqlite (withSqlitePool)+import Database.Persist.TH++-- |List of database backends+data Backend = Sqlite | Postgres++instance IsString Backend where+    fromString "sqlite"     = Sqlite+    fromString "postgres"   = Postgres+    fromString "postgresql" = Postgres++    -- Using `error` isn't great, but this is a fatal, unrecoverable,+    -- thing.+    fromString str = error $ "Unknown database backend " ++ str++-- |Run a database function which takes a connection pool+withPool :: (MonadIO m, MonadBaseControl IO m)+         => Backend                -- ^ The backend type+         -> Text                   -- ^ The connection string+         -> Int                    -- ^ The pool size+         -> (ConnectionPool -> m a) -- ^ The function+         -> m a+withPool Sqlite   = withSqlitePool+withPool Postgres = withPostgresqlPool . encodeUtf8++-- |Run a database function with a connection pool+runDB :: (MonadIO m, MonadBaseControl IO m)+      => ((ConnectionPool -> m a) -> m a) -- ^ The connection pool+      -> SqlPersistM a -- ^ The database function+      -> m a+runDB pool f = pool $ liftIO . runPool f++-- |Process a database function which takes a connection pool+runPool :: SqlPersistM a -> ConnectionPool -> IO a+runPool = runSqlPersistMPool++--------------------++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+SeacatIPBan+    -- Name used to identify routes where the ban applies+    applies Text+    expires UTCTime+    reason  Text++    -- These are IP addresses converted to numbers for comparison.+    -- Todo: Use a proper IP range type (requires more instances)+    start Rational+    stop  Rational+    deriving Show++SeacatRateLimit+    applies Text+    expires UTCTime+    target  String+    deriving Show++SeacatAntiFlood+    applies Text+    expires UTCTime+    target  String+    deriving Show+|]
+ src/Web/Seacat/RequestHandler.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE OverloadedStrings #-}++-- |Building up responses. This module provides a bunch of functions+-- to turn some primitive value into a handler, and the child modules+-- provide more complex handler composition.+--+-- In addition to response building, there are helper functions for+-- accessing the request parameters.+module Web.Seacat.RequestHandler ( -- * Response builders+                                   htmlResponse+                                 , htmlResponse'++                                 , htmlUrlResponse+                                 , htmlUrlResponse'++                                 , textResponse+                                 , textResponse'++                                 , textUrlResponse+                                 , textUrlResponse'++                                 , respond+                                 , respondFile++                                 -- * Redirection+                                 , redirect++                                 -- * Parameter accessors+                                 , param+                                 , param'+                                 , hasParam+                                 , params++                                 -- * File upload handling+                                 , files+                                 , save+                                 , save') where++import Prelude hiding (writeFile)++import Blaze.ByteString.Builder (Builder)+import Blaze.ByteString.Builder.ByteString (fromByteString)+import Control.Applicative ((<$>))+import Control.Monad.IO.Class (liftIO)+import Data.ByteString (unpack)+import Data.ByteString.Lazy (ByteString, writeFile)+import Data.Char (chr)+import Data.Maybe (isJust, fromMaybe)+import Data.Text (Text, pack)+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Types.Status (Status, ok200, found302)+import Network.Mime (defaultMimeLookup)+import Network.Wai (responseBuilder, responseFile, responseLBS)+import System.Directory (doesFileExist)+import System.FilePath.Posix (joinPath, takeExtension, takeFileName)+import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)+import Web.Seacat.Configuration (conf')+import Web.Seacat.RequestHandler.Types++-- |Produce a 200 OK response from the given HTML.+htmlResponse :: PathInfo r => Html -> Handler r+htmlResponse = htmlResponse' ok200++-- |Produce a response from the given HTML and response code.+htmlResponse' :: PathInfo r => Status -> Html -> Handler r+htmlResponse' status html = respond status $ renderHtmlBuilder html++-------------------------++-- |Produce a 200 OK response from the given HTML-generating+-- function.+htmlUrlResponse :: PathInfo r => (MkUrl r -> Html) -> Handler r+htmlUrlResponse = htmlUrlResponse' ok200++-- |Produce a response from the given HTML-generating function and+-- response code.+htmlUrlResponse' :: PathInfo r => Status -> (MkUrl r -> Html) -> Handler r+htmlUrlResponse' status html = do+  mkurl <- askMkUrl+  let builder = renderHtmlBuilder $ html mkurl+  respond status builder++-------------------------++-- |Produce a 200 OK response from the given UTF-8 text.+textResponse :: PathInfo r => Text -> Handler r+textResponse = textResponse' ok200++-- |Produce a response from the given UTF-8 text and response+-- code.+textResponse' :: PathInfo r => Status -> Text -> Handler r+textResponse' status = respond status . fromByteString . encodeUtf8++-------------------------++-- |Produce a 200 OK response from the given UTF-8 text-generating+-- function.+textUrlResponse :: PathInfo r => (MkUrl r -> Text) -> Handler r+textUrlResponse = textUrlResponse' ok200++-- |Produce a response from the given UTF-8 text-generating function+-- and response code.+textUrlResponse' :: PathInfo r => Status -> (MkUrl r -> Text) -> Handler r+textUrlResponse' status text = do+  mkurl <- askMkUrl+  respond status . fromByteString . encodeUtf8 $ text mkurl++-------------------------++-- |Produce a response from the given status and ByteString+-- builder. This sets a content-type of UTF-8 HTML.+respond :: PathInfo r => Status -> Builder -> Handler r+respond status = return . responseBuilder status [("Content-Type", "text/html; charset=utf-8")]++-- |Produce a response from the given file path (minus file+-- root). Call the provided 404 handler if the file isn't found.+respondFile :: PathInfo r => Handler r -> FilePath -> Handler r+respondFile on404 fp = do+  fileroot <- conf' "server" "file_root"+  let fullPath = joinPath [fileroot, fp]++  respondFile' on404 fullPath++-- |Produce a response from the given file path (including any+-- root). Call the provided 404 handler if the file isn't found.+--+-- This is somewhat unsafe as it lets you access files outside the+-- file root, hence why it isn't exported.+respondFile' :: PathInfo r => Handler r -> FilePath -> Handler r+respondFile' on404 fp = do+  exists <- liftIO $ doesFileExist fp+  if exists+  then return $ responseFile ok200 [("Content-Type", defaultMimeLookup $ pack fp)] fp Nothing+  else on404++-------------------------++-- |Produce a response to redirect the user.+redirect :: PathInfo r => r -> Handler r+redirect url = do+  mkurl <- askMkUrl+  return $ responseLBS found302 [("Location", encodeUtf8 $ mkurl url [])] ""++-------------------------++-- |Get a parameter by name. Returns a Maybe Text, where the Text is+-- the value of the parameter, interpreted as a UTF-8 string.+param :: PathInfo r+      => Text -- ^ The name of the parameter+      -> RequestProcessor r (Maybe Text)+param p = lookup p <$> params++-- |Get a parameter with a default value.+param' :: PathInfo r+       => Text -- ^ The parameter name+       -> Text -- ^ The default value+       -> RequestProcessor r Text+param' p d = fromMaybe d <$> lookup p <$> params++-- |Check if a parameter is set+hasParam :: PathInfo r+         => Text -- ^ The parameter name+         -> RequestProcessor r Bool+hasParam p = isJust <$> lookup p <$> params++-- |Get all non-file parameters, with the contents interpreted as+-- UTF-8 strings.+params :: PathInfo r => RequestProcessor r [(Text, Text)]+params = _params <$> askCry++-------------------------++-- |Get all files, stored in memory as a lazy bytestring.+files :: PathInfo r => RequestProcessor r [(Text, FileInfo ByteString)]+files = _files <$> askCry++-- |Save a file to a location relative to the filesystem root,+-- returning the name. File extension is preserved.+save :: PathInfo r => FilePath -> FileInfo ByteString -> RequestProcessor r Text+save fname (FileInfo name _ content) = do+  fileroot <- conf' "server" "file_root"+  let ext    = takeExtension (map (chr . fromIntegral) $ unpack name)+  let path   = joinPath [fileroot, fname]+  let fname' = path ++ ext++  liftIO $ writeFile fname' content++  return . pack $ takeFileName fname'++-- |Save a file to a location relative to the filesystem root, with+-- the path given as segments, returning the name. File extension is+-- preserved.+save' :: PathInfo r => [FilePath] -> FileInfo ByteString -> RequestProcessor r Text+save' = save . joinPath
+ src/Web/Seacat/RequestHandler/BanHammer.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}++-- |Higher-level handlers to do with banning people.+-- Each of the functions here is of the same basic form, they take a+-- `Tag`, possibly some parameter to determine if a ban or limit is in+-- effect, a handler to apply on the case of ban, and a handler to+-- apply on the case of success.+-- Tags are just a name used to identify a route, they may be shared+-- amongst routes.+module Web.Seacat.RequestHandler.BanHammer ( Tag+                                           , ipBan+                                           , floodProtect+                                           , rateLimit+                                           , rateLimit') where++import Control.Applicative ((<$>))+import Control.Monad.IO.Class (liftIO)+import Data.Bits ((.|.), shift)+import Data.Text (Text)+import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime)+import Data.Word ()+import Database.Persist+import Network.Socket (SockAddr(..))+import Network.Wai (remoteHost)+import Web.Routes.PathInfo (PathInfo)+import Web.Seacat.Database+import Web.Seacat.RequestHandler.Types (Handler, RequestProcessor, askReq)++-- |A handy name to identify a route.+type Tag = Text++-- |Rate limit a particular route. This only looks at individual IPs,+-- and not ranges.+rateLimit :: PathInfo r+          => Tag+          -> NominalDiffTime+            -- ^ How frequently an individual can access this route.+          -> (UTCTime -> Handler r)+            -- ^ Takes the limit expiration time as a parameter.+          -> Handler r+          -> Handler r+rateLimit tag freq onLimit handler = do+  limited <- isRateLimited tag+  now     <- liftIO getCurrentTime+  ip      <- show . remoteHost <$> askReq++  case limited of+    Just t -> onLimit t+    Nothing -> do+      let banUntil = addUTCTime freq now+      _ <- insert $ SeacatRateLimit tag banUntil ip+      handler++-- |Don't let someone past if they are rate limited, but don't set a+-- new limit if there isn't one already. The parameters are as in+-- `rateLimit`.+rateLimit' :: PathInfo r => Tag -> (UTCTime -> Handler r) -> Handler r -> Handler r+rateLimit' tag onLimit handler = do+  limited <- isRateLimited tag++  case limited of+    Just t -> onLimit t+    Nothing -> handler++-- | Check if an IP is rate limited. If it is, return when the limit+-- ends. This has the side-effect of clearing out all expired limits.+isRateLimited :: PathInfo r => Tag -> RequestProcessor r (Maybe UTCTime)+isRateLimited tag = do+  ip <- show . remoteHost <$> askReq++  now <- liftIO getCurrentTime++  deleteWhere [SeacatRateLimitExpires <. now]++  ban <- selectFirst [ SeacatRateLimitApplies ==. tag+                    , SeacatRateLimitTarget  ==. ip+                    ] []++  return $ (\(Entity _ b) -> seacatRateLimitExpires b) <$> ban++--------------------++-- |Check if someone is banned, and send them to the error handler if+-- so.+ipBan :: PathInfo r+      => Tag+      -> (UTCTime -> Text -> Handler r)+        -- ^ Takes the expiration time and reason of the ban as+        -- parameters.+      -> Handler r+      -> Handler r+ipBan tag onBan handler = do+  ip <- remoteHost <$> askReq++  now <- liftIO getCurrentTime++  deleteWhere [SeacatIPBanExpires <. now]++  ban <- selectFirst [ SeacatIPBanApplies ==. tag+                    , SeacatIPBanStart <=. ipToRational ip+                    , SeacatIPBanStop >=. ipToRational ip+                    ] []+  case ban of+    Just (Entity _ ipban) -> onBan (seacatIPBanExpires ipban) (seacatIPBanReason ipban)+    Nothing -> handler++-- |Convert an IP address into a Rational, the type I'm using in the+-- database to represent them.+ipToRational :: SockAddr -> Rational+ipToRational (SockAddrInet _ hostAddr) = fromIntegral hostAddr+ipToRational (SockAddrInet6 _ _ (a, b, c, d) _) = let a' = shift (fromIntegral a :: Integer) 96+                                                      b' = shift (fromIntegral b :: Integer) 64+                                                      c' = shift (fromIntegral c :: Integer) 32+                                                      d' = fromIntegral d+                                                  in fromIntegral $ a' .|. b' .|. c' .|. d'+ipToRational (SockAddrUnix _) = -1++--------------------++-- |Flood protect a particular route. This only looks at individual+-- IPs and not ranges. If multiple routes share this tag, they should+-- use the same time period.+floodProtect :: PathInfo r+             => Tag+             -> NominalDiffTime+               -- ^ The time period covered by the protection+             -> Int+               -- ^ How many times in the time period an IP can access+               -- this tag.+             -> Handler r+             -> Handler r+             -> Handler r+floodProtect tag time accesses onFlood handler = do+  ip <- show . remoteHost <$> askReq+  now <- liftIO getCurrentTime++  deleteWhere [SeacatAntiFloodExpires <. now]++  flood <- ((>=accesses) . length) <$> selectList [ SeacatAntiFloodApplies ==. tag+                                                , SeacatAntiFloodTarget  ==. ip+                                                ] []++  if flood+  then onFlood+  else do+    let expires = addUTCTime time now+    _ <- insert $ SeacatAntiFlood tag expires ip+    handler
+ src/Web/Seacat/RequestHandler/OnMethod.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-- |Higher-level handlers to restrict acecss based on HTTP method.+module Web.Seacat.RequestHandler.OnMethod ( on+                                          , onGet+                                          , onPost) where++import Control.Applicative ((<$>))+import Data.Either.Utils (forceEither)+import Network.HTTP.Types.Method (StdMethod(..), parseMethod)+import Network.Wai (requestMethod)+import Web.Routes.PathInfo (PathInfo)+import Web.Seacat.RequestHandler.Types (Handler, askReq)++-- |Run the provided handler on a GET request+--+-- For example, you can use this as follows:+--+-- > let error405 = utf8Response methodNotAllowed405 "This route only works via GET"+-- > in error405 `onGet` doThings+onGet :: PathInfo r+      => Handler r -- ^ The error handler+      -> Handler r -- ^ The handler+      -> Handler r+onGet = on GET++-- |Run the provided handler on a POST request+onPost :: PathInfo r+       => Handler r -- ^ The error handler+       -> Handler r -- ^ The handler+       -> Handler r+onPost = on POST++-- |Run the provided handler if the HTTP method matches, running the+-- error handler if not. The error handler should respond with an HTTP+-- 405 code.+on :: PathInfo r+   => StdMethod -- ^ The method to run on+   -> Handler r -- ^ The handler to call if the method doesn't match.+   -> Handler r -- ^ The handler+   -> Handler r+on method on405 handler = do+  rmethod <- forceEither . parseMethod . requestMethod <$> askReq++  if rmethod == method+  then handler+  else on405
+ src/Web/Seacat/RequestHandler/Types.hs view
@@ -0,0 +1,62 @@+-- |Types used by request handlers.+module Web.Seacat.RequestHandler.Types+    ( FileInfo(..)+    , PathInfo(..)+    , module Web.Seacat.RequestHandler.Types+    ) where++import Control.Applicative((<$>))+import Control.Monad.Trans.Reader (ReaderT, ask)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.ConfigFile (ConfigParser)+import Data.Text (Text)+import Database.Persist.Sql (SqlPersistM)+import Network.Wai (Request, Response)+import Network.Wai.Parse (FileInfo(..))+import Web.Routes.PathInfo (PathInfo(..))++-- |Type to represent a Seacat request+data Cry r = Cry+    { _req    :: Request+    -- ^ The underlying WAI request.++    , _params :: [(Text, Text)]+    -- ^ The parameters, parsed once before the top-level handler is+    -- called.++    , _files  :: [(Text, FileInfo ByteString)]+    -- ^ The files, stored in memory as lazy bytestrings, and parsed+    -- out of the request once at the beginning.++    , _conf :: ConfigParser+    -- ^ The contents of the configuration file++    , _mkurl :: MkUrl r+    -- ^ The URL building function+    }++-- |Function to make URLs from some routing type+type MkUrl r = r -> [(Text, Text)] -> Text++-- |Function which handles a request+type RequestProcessor r = ReaderT (Cry r) SqlPersistM++-- |`RequestProcessor` specialised to producing a `Response`. All+-- routes should go to a function of type `PathInfo r => Handler r`.+type Handler r = RequestProcessor r Response++-- |Get the configuration from a `RequestProcessor`+askConf :: PathInfo r => RequestProcessor r ConfigParser+askConf = _conf <$> askCry++-- |Get the URL maker from a `RequestProcessor`+askMkUrl :: PathInfo r => RequestProcessor r (MkUrl r)+askMkUrl = _mkurl <$> askCry++-- |Get the seacat request from a `RequestProcessor`+askCry :: PathInfo r => RequestProcessor r (Cry r)+askCry = ask++-- |Get the WAI request from a `RequestProcessor`+askReq :: PathInfo r => RequestProcessor r Request+askReq = _req <$> askCry
+ src/Web/Seacat/Router.hs view
@@ -0,0 +1,68 @@+-- |This is a port of (what I use of) Web.Routes.Wai to Wai 3.0, as I+-- got tired of waiting for upstream to update.+module Web.Seacat.Router ( handleWai+                         , handleWai_+                         , handleWaiError ) where++import Data.Text (Text, append)+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Types (status404)+import Network.Wai (Application, rawPathInfo , responseLBS)+import Web.Routes.PathInfo (PathInfo(..), fromPathInfo, toPathInfoParams, stripOverlapBS)++import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy.Char8 as L++-- | A URL pretty printer. This is like MkUrl from+-- Web.Seacat.RequestHandler.Types, except that it uses a (Text, Maybe+-- Text) to stick close to web-routes-wai, easing migration back when+-- it is finally updated.+type MkUrl r = r -> [(Text, Maybe Text)] -> Text++-- | A URL parser. This turns a URL into either an error message, or a+-- parsed URL type, suitable for giving to the routing function.+type FromUrl r = C.ByteString -> Either String r++-- | A routing function type.+-- +-- Takes a URL printing function and a parsed URL and returns the+-- appropriate Application for that URL.+type RoutingFunction r = MkUrl r -> r -> Application++-- |Convert a routing function into an Application by using PathInfo.+handleWai :: PathInfo r+          => C.ByteString -- ^ The application web route+          -> RoutingFunction r+          -> Application+handleWai = handleWai_ toPathInfoParams fromPathInfo++-------------------------++-- |Convert a URL parser, a URL printer, and a routing function into+-- an Application. If the URL parsing fails, this returns a 404.+handleWai_ :: MkUrl r+           -> FromUrl r+           -> C.ByteString -- ^ The application web route+           -> RoutingFunction r+           -> Application+handleWai_ fromUrl toUrl approot handler =+    handleWaiError fromUrl toUrl approot handleError handler+    where+      handleError parseError  = \wreq receiver -> handleError' parseError wreq >>= receiver+      handleError' parseError = \_ -> return $ responseLBS status404 [] (L.pack parseError)++-------------------------++-- |Convert a URL parser, a URL printer, an error handling function,+-- and a routing function into an application.+handleWaiError :: MkUrl r+               -> FromUrl r+               -> C.ByteString -- ^ The application web route+               -> (String -> Application) -- ^ Error handling function+               -> RoutingFunction r+               -> Application+handleWaiError fromUrl toUrl approot handleError handler = \req receiver -> do+  let fUrl = toUrl $ stripOverlapBS approot $ rawPathInfo req+  case fUrl of+    Left err  -> handleError err req receiver+    Right url -> handler (\url params -> (decodeUtf8 approot) `append` (fromUrl url params)) url req receiver
+ src/Web/Seacat/Server.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE OverloadedStrings #-}++-- |Here lives everything to do with starting up a Seacat server.+module Web.Seacat.Server ( SeacatSettings(..)+                         , defaultSettings+                         , seacat) where++import Control.Arrow ((***), first, second)+import Control.Monad (when, void)+import Control.Monad.Trans.Reader (runReaderT)+import Data.Either.Utils (forceEither)+import Data.Maybe (fromJust, fromMaybe)+import Data.String (fromString)+import Data.Text (replace)+import Data.Text.Encoding (decodeUtf8)+import Data.Time.Clock (getCurrentTime)+import Database.Persist ((<.), deleteWhere)+import Database.Persist.Sql (ConnectionPool, Migration, SqlPersistM, runMigration)+import Network.HTTP.Types.Method (StdMethod(..), parseMethod)+import Network.Wai (Application, requestMethod, queryString)+import Network.Wai.Handler.Warp (runSettings, setHost, setPort)+import Network.Wai.Middleware.Gzip (GzipSettings(..), GzipFiles(GzipCompress), gzip, gzipFiles, def)+import Network.Wai.Middleware.Static (addBase, staticPolicy)+import Network.Wai.Parse (parseRequestBody, lbsBackEnd)+import System.Environment (getArgs)+import System.Exit (exitFailure)+import System.IO.Error (catchIOError)+import Web.Routes.PathInfo (PathInfo)++import Web.Seacat.Configuration (ConfigParser, applyUserConfig, defaults, get', loadConfigFile, reloadConfigFile)+import Web.Seacat.Database+import Web.Seacat.RequestHandler.Types (Cry(..), MkUrl, Handler, _req, _params, _files)+import Web.Seacat.Router (handleWai)++import qualified Network.Wai.Handler.Warp as W++-- |Optional configuration for Seacat servers+data SeacatSettings = SeacatSettings+    { _config   :: Maybe ConfigParser+      -- ^ Default configuration, overriding the defaults. This should+      -- include all application-required configuration not already+      -- provided by Seacat. Configuration is applied as follows,+      -- where \`merge\` overrides the values in its first argument by+      -- the values in its second,+      --+      --     seacat defaults \`merge\` application config \`merge\` user config+      --+      -- This ensures that all the required configuration values are set.++    , _migrate  :: Maybe (Migration SqlPersistM)+      -- ^ Database migration handler. If a database is used, this must+      -- be provided (or migrations handled manually in runserver).++    , _populate :: Maybe (SqlPersistM ())+      -- ^ Database population handler. If a database is used, this+      -- must be provided (or population handled manually in+      -- runserver).++    , _clean :: Maybe (SqlPersistM ())+      -- ^ Database clean handler. This is optional.++    , _gzip :: GzipSettings+      -- ^ The settings to use for Gzip compression.+    }++-- |Default configuration: no application-specific configuration, no+-- migration handler, no population handler, and gzip if the browser+-- accepts it.+defaultSettings :: SeacatSettings+defaultSettings = SeacatSettings { _config   = Nothing+                                 , _migrate  = Nothing+                                 , _populate = Nothing+                                 , _clean    = Nothing+                                 , _gzip     = def { gzipFiles = GzipCompress }+                                 }++-- |Launch the Seacat web server. Seacat takes two bits of mandatory+-- configuration, a routing function and a 500 handler, and then some+-- optional configuration. By default, the server listens on *:3000.+seacat :: PathInfo r+       => (StdMethod -> r -> Handler r) -- ^ Routing function+       -> (String -> Handler r) -- ^ Top-level error handling function+       -> SeacatSettings -- ^ Optional configuration+       -> IO ()+seacat route on500 settings = do+  args <- getArgs++  when (length args < 1) $+    die "Expected at least one argument"++  let command = head args++  let confFile = case args of+                   (_:conffile:_) -> Just conffile+                   _ -> Nothing++  config <- case confFile of+             Just cfile -> loadConfigFile cfile+             Nothing -> return $ Just defaults++  case config of+    Just conf -> let conf' = applyUserConfig conf (_config settings)+                     backend  = get' conf' "database" "backend"+                     connstr  = get' conf' "database" "connection_string" +                     poolsize = get' conf' "database" "pool_size"++                     pool = withPool (fromString backend) (fromString connstr) poolsize++                     settings' = settings { _config = Just conf' }+                 in run command route on500 confFile pool settings'+    Nothing   -> die "Failed to read configuration"++-- |Die with a fatal error+die :: String -- ^ The error description+    -> IO ()+die err = putStrLn err >> exitFailure++-------------------------++-- |Run one of the applications, depending on the command+run :: PathInfo r+    => String -- ^ Command+    -> (StdMethod -> r -> Handler r) -- ^ Routing function+    -> (String -> Handler r) -- ^ Top-level error handling function+    -> Maybe FilePath -- ^ The config file+    -> ((ConnectionPool -> IO ()) -> IO ()) -- ^ Database connection pool runner+    -> SeacatSettings -- ^ The optional settings+    -> IO ()+run "runserver" = runserver+run "migrate"   = migrate+run "populate"  = populate+run "clean"     = clean+run _           = badcommand++-- |Run the server+runserver :: PathInfo r+          => (StdMethod -> r -> Handler r)+          -> (String -> Handler r)+          -> Maybe FilePath+          -> ((ConnectionPool -> IO ()) -> IO ())+          -> SeacatSettings+          -> IO ()+runserver route on500 cfile pool settings = do+  let conf = fromJust $ _config settings++  let host = get' conf "server" "host"+  let port = get' conf "server" "port"++  void $ clean route on500 cfile pool settings++  let settings' = setHost (fromString host) . setPort port $ W.defaultSettings++  putStrLn $ unlines [ " _ _  _. _ _._|_ "+                     , "_>(/_(_|(_(_| |_ "]+  putStrLn $ "Listening on " ++ host ++ ":" ++ show port+  pool $ runSettings settings' . runner settings route on500 (conf,cfile)++-- |Migrate the database+migrate :: PathInfo r+        => (StdMethod -> r -> Handler r)+        -> (String -> Handler r)+        -> Maybe FilePath+        -> ((ConnectionPool -> IO ()) -> IO ())+        -> SeacatSettings+        -> IO ()+migrate _ _ _ pool settings = do+  runDB pool $ runMigration migrateAll++  case _migrate settings of+    Just migration -> runDB pool $ runMigration migration+    Nothing -> putStrLn "No application migration handler."++-- |Populate the database with test data+populate :: PathInfo r+         => (StdMethod -> r -> Handler r)+         -> (String -> Handler r)+         -> Maybe FilePath+         -> ((ConnectionPool -> IO ()) -> IO ())+         -> SeacatSettings+         -> IO ()+populate _ _ _ pool settings =+    case _populate settings of+      Just pop -> runDB pool pop+      Nothing -> die "No population handler."++-- |Clean out expired bans from the database+clean :: PathInfo r+      => (StdMethod -> r -> Handler r)+      -> (String -> Handler r)+      -> Maybe FilePath+      -> ((ConnectionPool -> IO ()) -> IO ())+      -> SeacatSettings+      -> IO ()+clean _ _ _ pool settings = do+  now <- getCurrentTime++  runDB pool $ do+    deleteWhere [SeacatRateLimitExpires <. now]+    deleteWhere [SeacatIPBanExpires     <. now]+    deleteWhere [SeacatAntiFloodExpires <. now]++  case _clean settings of+    Just cln -> runDB pool cln+    Nothing -> putStrLn "No application clean handler."++-- |Fail with an error+badcommand :: PathInfo r+           => (StdMethod -> r -> Handler r)+           -> (String -> Handler r)+           -> Maybe FilePath+           -> ((ConnectionPool -> IO ()) -> IO ())+           -> SeacatSettings+           -> IO ()+badcommand _ _ _ _ _ = die "Unknown command"++-------------------------++-- |runner is the actual WAI application. It takes a request, handles+-- it, and produces a response.+runner :: PathInfo r+       => SeacatSettings -- ^ The settings+       -> (StdMethod -> r -> Handler r)    -- ^ Routing function+       -> (String -> Handler r)           -- ^ Top-level error handling function+       -> (ConfigParser, Maybe FilePath) -- ^ The configuration+       -> ConnectionPool                 -- ^ Database connection reference+       -> Application+runner settings route on500 c@(conf,_) pool = handleWai (fromString webroot) $ \mkurl r ->+  -- This is horrific, come up with a better way of doing it+  let mkurl' r' args = replace "%23" "#" . mkurl r' $ map (\(a,b) -> (a, if b == "" then Nothing else Just b)) args+  in staticPolicy (addBase fileroot) $+     gzip (_gzip settings) $+     process route on500 c pool mkurl' r++  where webroot  = get' conf "server" "web_root"+        fileroot = get' conf "server" "file_root"++-- |Route and process a request+-- Todo: use SqlPersistT?+process :: PathInfo r+        => (StdMethod -> r -> Handler r) -- ^ Routing function+        -> (String -> Handler r)        -- ^ Top-level error handling function+        -> (ConfigParser, Maybe FilePath) -- ^ The configuration+        -> ConnectionPool              -- ^ Database connection reference+        -> MkUrl r                     -- ^ URL building function+        -> r                           -- ^ Requested route+        -> Application+process route on500 (conf,cfile) pool mkurl path req receiver = requestHandler `catchIOError` runError+  where requestHandler = runHandler' $ route method path+        runError err   = runHandler' $ on500 (show err)+        runHandler' h  = runHandler h conf cfile pool mkurl req receiver +        method         = forceEither . parseMethod . requestMethod $ req++-- |Run a request handler.+runHandler :: PathInfo r+           => Handler r -- ^ The handler to run+           -> ConfigParser+           -> Maybe FilePath+           -> ConnectionPool+           -> MkUrl r+           -> Application+runHandler h conf cfile pool mkurl req receiver = do+  -- Reload the config+  conf' <- case cfile of+            Just cf -> reloadConfigFile conf cf+            Nothing -> return conf++  -- Build the Cry+  (ps, fs) <- parseRequestBody lbsBackEnd req+  let ps' = map (second $ fromMaybe "") $ queryString req+  let cry = Cry { _req    = req+                , _params = map (decodeUtf8 *** decodeUtf8) (ps ++ ps')+                , _files  = map (first decodeUtf8) fs+                , _conf   = conf'+                , _mkurl  = mkurl+                }++  runPool (runReaderT h cry) pool >>= receiver