diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/seacat.cabal b/seacat.cabal new file mode 100644 --- /dev/null +++ b/seacat.cabal @@ -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] + . + [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 + diff --git a/src/Web/Seacat.hs b/src/Web/Seacat.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat.hs @@ -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 diff --git a/src/Web/Seacat/Configuration.hs b/src/Web/Seacat/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/Configuration.hs @@ -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 diff --git a/src/Web/Seacat/Database.hs b/src/Web/Seacat/Database.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/Database.hs @@ -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 +|] diff --git a/src/Web/Seacat/RequestHandler.hs b/src/Web/Seacat/RequestHandler.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/RequestHandler.hs @@ -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 diff --git a/src/Web/Seacat/RequestHandler/BanHammer.hs b/src/Web/Seacat/RequestHandler/BanHammer.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/RequestHandler/BanHammer.hs @@ -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 diff --git a/src/Web/Seacat/RequestHandler/OnMethod.hs b/src/Web/Seacat/RequestHandler/OnMethod.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/RequestHandler/OnMethod.hs @@ -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 diff --git a/src/Web/Seacat/RequestHandler/Types.hs b/src/Web/Seacat/RequestHandler/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/RequestHandler/Types.hs @@ -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 diff --git a/src/Web/Seacat/Router.hs b/src/Web/Seacat/Router.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/Router.hs @@ -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 diff --git a/src/Web/Seacat/Server.hs b/src/Web/Seacat/Server.hs new file mode 100644 --- /dev/null +++ b/src/Web/Seacat/Server.hs @@ -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