packages feed

wobsurv (empty) → 0.1.0

raw patch · 23 files changed

+1786/−0 lines, 23 filesdep +HTFdep +HUnitdep +QuickChecksetup-changed

Dependencies added: HTF, HUnit, QuickCheck, aeson, attoparsec, base-prelude, bytestring, hastache, http-client, http-types, lifted-async, monad-control, mwc-random, network, network-simple, old-locale, pipes, pipes-bytestring, pipes-network, pipes-parse, pipes-safe, pipes-text, quickcheck-instances, safe, stm, stm-containers, system-fileio, system-filepath, text, time, transformers, unordered-containers, wobsurv, yaml

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2014, Nikita Volkov++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ library/Wobsurv.hs view
@@ -0,0 +1,93 @@+module Wobsurv where++import BasePrelude+import Control.Monad.Trans.Class+import Data.Text (Text)+import Data.ByteString (ByteString)+import Data.HashMap.Strict (HashMap)+import Filesystem.Path (FilePath)+import qualified Wobsurv.Util.OpenServer.ConnectionsManager as OpenServer.ConnectionsManager+import qualified Wobsurv.Util.OpenServer.Connection as OpenServer.Connection+import qualified Wobsurv.Util.Mustache.Renderer as Mustache.Renderer+import qualified Wobsurv.Util.MasterThread as MasterThread+import qualified Wobsurv.Util.WorkerThread as WorkerThread+import qualified Wobsurv.Interaction+import qualified Wobsurv.Response+import qualified Wobsurv.Logging+import qualified Data.ByteString as ByteString+import qualified Filesystem+import qualified Filesystem.Path.CurrentOS as FilePath+++-- |+-- Settings for running the server.+data Settings =+  Settings {+    -- |+    -- Whether to log requests in the 'stdout'.+    logging :: Bool,+    -- |+    -- A port to listen on.+    port :: Word,+    -- | +    -- A maximum amount of clients.+    -- When this amount is reached the server rejects all the further connections +    -- with a "Service Unavailable" status.+    connectionsLimit :: Word,+    -- |+    -- A path to the directory containing template files for server responses.+    templatesDir :: FilePath,+    -- |+    -- A directory, the contents of which should be served.+    contentDir :: FilePath,+    -- |+    -- MIME content-type mappings.+    mimeMappings :: HashMap Text ByteString+  }+  deriving (Show)++-- |+-- Run the server with the provided settings.+-- +-- This operation is blocking. +-- If you need to be able to stop the server run it in a separate thread,+-- killing that thread will stop the server and +-- properly release all the resources acquired by the server.+serve :: Settings -> IO ()+serve settings =+  MasterThread.run $ do+    renderer <- lift $ Mustache.Renderer.new (templatesDir settings)+    printerThread <- WorkerThread.new 1000+    let+      logger =+        if logging settings+          then +            \m -> MasterThread.runWithoutForking $ +              WorkerThread.schedule (lift $ Wobsurv.Logging.log m) printerThread+          else +            const $ return ()+      allowedConnectionHandler =+        lift . OpenServer.Connection.session timeout interactor+        where+          interactor =+            Wobsurv.Interaction.run Wobsurv.Interaction.interaction $+              Wobsurv.Interaction.Settings +                (logger)+                (contentDir settings)+                (mimeMappings settings)+                (Nothing)+                (renderer)+      disallowedConnectionHandler =+        lift . OpenServer.Connection.rejection timeout rejector+        where+          rejector =+            Wobsurv.Response.runInProducer Wobsurv.Response.serviceUnavailable renderer+    OpenServer.ConnectionsManager.listen $+      OpenServer.ConnectionsManager.Settings +        (port settings) +        (connectionsLimit settings)+        allowedConnectionHandler+        disallowedConnectionHandler+  where+    timeout = 1 * 10 ^ 6+
+ library/Wobsurv/Interaction.hs view
@@ -0,0 +1,114 @@+module Wobsurv.Interaction where++import BasePrelude hiding (bracket, for, yield, log)+import Pipes+import Pipes.Safe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified Wobsurv.Util.PipesAttoparsec as PipesAttoparsec+import qualified Wobsurv.Util.HTTP.Parser as Parser+import qualified Wobsurv.Util.HTTP.Model as Protocol+import qualified Wobsurv.Util.HTTP.URLEncoding as URLEncoding+import qualified Wobsurv.Util.Mustache.Renderer as TemplatesRenderer+import qualified Wobsurv.TemplateModels.NotFound as NotFound+import qualified Wobsurv.Response as Response+import qualified Pipes.Parse+import qualified Data.ByteString+import qualified Data.HashMap.Strict+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Filesystem.Path.CurrentOS as Path+import qualified Filesystem+import qualified Network.HTTP.Types.URI+++type BS = +  Data.ByteString.ByteString++type Path =+  Path.FilePath++type Text =+  Data.Text.Text++data Settings =+  Settings {+    logger :: Summary -> IO (),+    contentDir :: Path,+    mimeMappings :: Data.HashMap.Strict.HashMap Text BS,+    -- | In microseconds.+    keepAliveTimeout :: Maybe Word,+    templatesRenderer :: TemplatesRenderer.Renderer+  }++type Summary =+  (Maybe (Protocol.Method, Protocol.RelativeURI), Protocol.Status)++-- | +-- A producing parser.+-- Consumes the input and generates the output.+type Interaction r = +  Pipes.Parse.Parser BS (ReaderT Settings (Producer BS (SafeT IO))) r++run :: Interaction r -> Settings -> (Producer BS (SafeT IO) () -> Producer BS (SafeT IO) r)+run server settings = +  flip runReaderT settings . evalStateT server . hoist (lift . lift)++-- |+-- Returns the next keep-alive-timeout, +-- if it's nothing, then the connection should be closed.+interaction :: Interaction (Maybe Word)+interaction =+  do+    settings <- lift $ ask+    PipesAttoparsec.liftParserWithLimit 2048 Parser.head >>= \case+      Right (method, uri, version, headers) -> do+        let+          path = +            contentDir settings <> uriPath+          uriPath =+            maybe mempty URLEncoding.toFilePath $ case uri of (p, _, _) -> p+        case method of+          Left Protocol.Get ->+            (liftIO . Filesystem.isFile) path >>= \case+              False -> do+                (liftIO . Filesystem.isDirectory) path >>= \case+                  False -> do+                    log (Just (method, uri), Protocol.notFound)+                    liftResponse (Response.notFound uri)+                    return Nothing+                  True -> do+                    log (Just (method, uri), Protocol.ok)+                    liftResponse (Response.okIndex uriPath path (keepAliveTimeoutMicros settings))+                    return (keepAliveTimeout settings)+              True -> do+                log (Just (method, uri), Protocol.ok)+                liftResponse (Response.okFile path (keepAliveTimeoutMicros settings) (mimeMappings settings))+                return (keepAliveTimeout settings)+          _ -> do+            log (Nothing, Protocol.notImplemented)+            liftResponse Response.notImplemented+            return Nothing+      Left PipesAttoparsec.ConsumedTooMuch -> do+        log (Nothing, Protocol.entityTooLarge)+        liftResponse Response.entityTooLarge+        return Nothing+      _ -> do+        log (Nothing, Protocol.badRequest)+        liftResponse Response.badRequest+        return Nothing+  where+    keepAliveTimeoutMicros = +      fmap (`div` 1000000) . keepAliveTimeout++liftResponse :: Response.Response a -> Interaction a+liftResponse response =+  do+    settings <- lift $ ask+    lift $ lift $ Response.runInProducer response (templatesRenderer settings)++log :: Summary -> Interaction ()+log request =+  do+    settings <- lift $ ask+    liftIO $ (logger settings) request
+ library/Wobsurv/Logging.hs view
@@ -0,0 +1,44 @@+module Wobsurv.Logging where++import BasePrelude hiding (log)+import qualified Wobsurv.Interaction+import qualified System.Locale                 as Locale+import qualified Data.Time                     as Time+import qualified Wobsurv.Util.HTTP.Renderer    as HTTP.Renderer+import qualified Wobsurv.Util.HTTP.Model       as HTTP.Model+import qualified Wobsurv.Util.HTTP.URLEncoding as HTTP.URLEncoding+import qualified Data.ByteString               as ByteString+import qualified Data.ByteString.Builder       as ByteString.Builder+import qualified Data.ByteString.Lazy.Char8    as ByteString.Lazy.Char8+import qualified Data.Text.Lazy.IO             as Text.Lazy.IO+import qualified Data.Text.Lazy.Encoding       as Text.Lazy.Encoding+import qualified Data.Text.Lazy.Builder        as Text.Lazy.Builder+++log :: Wobsurv.Interaction.Summary -> IO ()+log (request, status) =+  Text.Lazy.IO.putStrLn =<< do+    time <- Time.formatTime Locale.defaultTimeLocale "%F %X %Z" <$> Time.getZonedTime+    return $ Text.Lazy.Builder.toLazyText $+      case request of+        Just (method, uri) ->+          Text.Lazy.Builder.fromString time <> +          Text.Lazy.Builder.fromString ": " <>+          (liftBSB $ HTTP.Renderer.status status) <> +          Text.Lazy.Builder.fromString " <-- " <>+          (liftBSB $ HTTP.Renderer.method method) <>+          Text.Lazy.Builder.singleton ' ' <>+          (Text.Lazy.Builder.fromText $ HTTP.URLEncoding.toText $ HTTP.Renderer.toByteString $ HTTP.Renderer.relativeURI uri)+        Nothing ->+          Text.Lazy.Builder.fromString time <> +          Text.Lazy.Builder.fromString ": " <>+          (liftBSB $ HTTP.Renderer.status status)+  where+    liftBSB =+      Text.Lazy.Builder.fromLazyText . Text.Lazy.Encoding.decodeLatin1 . ByteString.Builder.toLazyByteString++newSynchronizedLogger :: IO (Wobsurv.Interaction.Summary -> IO ())+newSynchronizedLogger = do+  loggerLock <- newMVar ()+  return $ +    \m -> withMVar loggerLock $ const $ log m
+ library/Wobsurv/RequestHeaders.hs view
@@ -0,0 +1,21 @@+module Wobsurv.RequestHeaders where++import BasePrelude+import qualified Wobsurv.Util.HTTP.Model as Protocol+++data RequestHeaders =+  RequestHeaders {+    connection :: Maybe Protocol.ConnectionHeader+  }++fromProtocolHeaders :: [Protocol.Header] -> RequestHeaders+fromProtocolHeaders =+  foldr step init+  where+    init =+      RequestHeaders Nothing+    step =+      \case+        Protocol.ConnectionHeader h -> \r -> r {connection = Just h}+        _ -> id
+ library/Wobsurv/Response.hs view
@@ -0,0 +1,202 @@+module Wobsurv.Response where++import BasePrelude hiding (bracket, for, yield, head)+import Pipes+import Pipes.Safe+import Control.Monad.Trans.Reader+import qualified Wobsurv.Util.HTTP.Renderer as ProtocolRenderer+import qualified Wobsurv.Util.HTTP.Model as Protocol+import qualified Wobsurv.Util.HTTP.URLEncoding as URLEncoding+import qualified Wobsurv.Util.Mustache.Renderer as TemplatesRenderer+import qualified Wobsurv.TemplateModels.NotFound as NotFound+import qualified Wobsurv.TemplateModels.Index as Index+import qualified Pipes.ByteString+import qualified Pipes.Text+import qualified Data.ByteString+import qualified Data.ByteString.Builder+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Data.Text.Lazy+import qualified Data.HashMap.Strict+import qualified Filesystem.Path as Path+import qualified Filesystem.Path.CurrentOS as Path.CurrentOS+import qualified Filesystem.Path.Rules as Path.Rules+import qualified Filesystem+++type BS = +  Data.ByteString.ByteString++type FilePath =+  Path.CurrentOS.FilePath++type Text =+  Data.Text.Text++type LazyText =+  Data.Text.Lazy.Text++type KeepAliveTimeout =+  Word++type MimeMappings =+  Data.HashMap.Strict.HashMap Text BS++type Env =+  TemplatesRenderer.Renderer++type Response r =+  ReaderT Env (Producer BS (SafeT IO)) r++runInProducer :: Response a -> Env -> Producer BS (SafeT IO) a+runInProducer = +  runReaderT++-- * Responses+-------------------------++serviceUnavailable :: Response ()+serviceUnavailable =+  do+    statusLine Protocol.serviceUnavailable+    connectionHeader False+    contentTypeHeader ("text/html", Just Protocol.UTF8)+    newLine+    template "service-unavailable" ()++badRequest :: Response ()+badRequest =+  do+    statusLine Protocol.badRequest+    connectionHeader False+    contentTypeHeader ("text/html", Just Protocol.UTF8)+    newLine+    template "bad-request" ()++notImplemented :: Response ()+notImplemented =+  do+    statusLine Protocol.notImplemented+    connectionHeader False+    contentTypeHeader ("text/html", Just Protocol.UTF8)+    newLine+    template "not-implemented" ()++entityTooLarge :: Response ()+entityTooLarge =+  do+    statusLine Protocol.entityTooLarge+    connectionHeader False+    contentTypeHeader ("text/html", Just Protocol.UTF8)+    newLine+    template "entity-too-large" ()++notFound :: Protocol.RelativeURI -> Response ()+notFound uri =+  do+    statusLine Protocol.notFound+    connectionHeader False+    contentTypeHeader ("text/html", Just Protocol.UTF8)+    newLine+    template "not-found" $+      NotFound.NotFound {+        NotFound.uri = +          URLEncoding.toText $ ProtocolRenderer.toByteString $ ProtocolRenderer.relativeURI uri +      }++okFile :: FilePath -> Maybe KeepAliveTimeout -> MimeMappings -> Response ()+okFile path keepAliveTimeout mimeMappings =+  do+    statusLine Protocol.ok+    case keepAliveTimeout of+      Nothing -> do+        connectionHeader False+      Just v -> do+        connectionHeader True+        keepAliveHeader (v, Nothing)+    forM_ contentType $ \x -> contentTypeHeader (x, Nothing)+    newLine+    file path+    where+      contentType = +        Path.extension path >>= \e -> Data.HashMap.Strict.lookup e mimeMappings++okIndex :: FilePath -> FilePath -> Maybe KeepAliveTimeout -> Response ()+okIndex uriPath path keepAliveTimeout =+  do+    statusLine Protocol.ok+    case keepAliveTimeout of+      Nothing -> do+        connectionHeader False+      Just v -> do+        connectionHeader True+        keepAliveHeader (v, Nothing)+    contentTypeHeader ("text/html", Just Protocol.UTF8)+    newLine+    contents <- do+      files <- do+        paths <- liftIO $ Filesystem.listDirectory path+        return $ map Path.filename paths+      if publicPath /= "/"+        then return $ ".." : files+        else return files+    template "index" $ Index.Index (pathRepr publicPath) (map pathRepr contents)+    where+      publicPath =+        Path.parent $ "/" <> uriPath <> "./"+      pathRepr =+        fromString . Path.CurrentOS.encodeString+++-- * Headers+-------------------------++contentTypeHeader :: Protocol.ContentTypeHeader -> Response ()+contentTypeHeader =+  liftBSBuilder . ProtocolRenderer.contentTypeHeader++connectionHeader :: Protocol.ConnectionHeader -> Response ()+connectionHeader =+  liftBSBuilder . ProtocolRenderer.connectionHeader++keepAliveHeader :: Protocol.KeepAliveHeader -> Response ()+keepAliveHeader =+  liftBSBuilder . ProtocolRenderer.keepAliveHeader++contentLengthHeader :: Protocol.ContentLengthHeader -> Response ()+contentLengthHeader =+  liftBSBuilder . ProtocolRenderer.contentLengthHeader++-- * Other+-------------------------++newLine :: Response ()+newLine =+  liftBSBuilder ProtocolRenderer.newLine++template :: (Data model) => Text -> model -> Response ()+template name model =+  do+    templatesRenderer <- ask+    traverse_ lazyText $ +      TemplatesRenderer.render model name templatesRenderer++lazyText :: LazyText -> Response ()+lazyText t =+  lift $ for (Pipes.Text.fromLazy t) (yield . Data.Text.Encoding.encodeUtf8)++file :: FilePath -> Response ()+file path =+  lift $+    bracket+      (liftIO $ Filesystem.openFile path Filesystem.ReadMode)+      (liftIO . hClose)+      Pipes.ByteString.fromHandle++statusLine :: Protocol.Status -> Response ()+statusLine status =+  liftBSBuilder $ ProtocolRenderer.statusLine (1, 1) status++liftBSBuilder :: Data.ByteString.Builder.Builder -> Response ()+liftBSBuilder =+  lift . Pipes.ByteString.fromLazy . Data.ByteString.Builder.toLazyByteString
+ library/Wobsurv/TemplateModels/Index.hs view
@@ -0,0 +1,13 @@+module Wobsurv.TemplateModels.Index where++import BasePrelude+import Data.Text (Text)+import Data.ByteString (ByteString)+++data Index = +  Index {+    path :: Text,+    contents :: [Text]+  }+  deriving (Show, Data, Typeable)
+ library/Wobsurv/TemplateModels/NotFound.hs view
@@ -0,0 +1,12 @@+module Wobsurv.TemplateModels.NotFound where++import BasePrelude+import Data.Text (Text)+import Data.ByteString (ByteString)+++data NotFound = +  NotFound {+    uri :: Text+  }+  deriving (Show, Data, Typeable)
+ library/Wobsurv/Util/HTTP/Model.hs view
@@ -0,0 +1,110 @@+module Wobsurv.Util.HTTP.Model where++import BasePrelude+import qualified Data.ByteString as ByteString+++type BS = +  ByteString.ByteString++type Version = +  (Word, Word)++-- * Headers+-------------------------++data Header =+  ConnectionHeader ConnectionHeader |+  ContentLengthHeader ContentLengthHeader |+  ContentTypeHeader ContentTypeHeader |+  KeepAliveHeader KeepAliveHeader+  deriving (Show, Read, Eq, Ord, Typeable, Generic)++-- | Specifies whether to keep the connection alive.+type ConnectionHeader =+  Bool++-- | A length of the content in octets.+type ContentLengthHeader =+  Word++-- | A MIME type of content and possibly a charset+type ContentTypeHeader =+  (BS, Maybe Charset)++-- | A timeout in seconds and possibly a maximum amount of requests.+type KeepAliveHeader =+  (Word, Maybe Word)++data Charset =+  UTF8+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)+++-- * Methods+-------------------------++data StandardMethod = +  Options | Get | Head | Post | Put | Delete | Trace | Connect+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)++type Method =+  Either StandardMethod BS+++-- * Statuses+-------------------------++type Status = +  (Word, BS)++ok                       :: Status = (200, "OK")+badRequest               :: Status = (400, "Bad Request")+unauthorized             :: Status = (401, "Unauthorized")+forbidden                :: Status = (403, "Forbidden")+notFound                 :: Status = (404, "Not Found")+methodNotAllowed         :: Status = (405, "Method Not Allowed")+requestTimeOut           :: Status = (408, "Request Time-out")+entityTooLarge           :: Status = (413, "Entity Too Large")+requestURITooLarge       :: Status = (414, "Request-URI Too Large")+notImplemented           :: Status = (501, "Not Implemented")+serviceUnavailable       :: Status = (503, "Service Unavailable")+httpVersionNotSupported  :: Status = (505, "HTTP Version not supported")+++-- * URI+-------------------------++data URI =+  AbsoluteURI !Scheme !Authority !(Maybe Port) !RelativeURI |+  SchemeRelativeURI !Authority !(Maybe Port) !RelativeURI |+  RelativeURI !RelativeURI+  deriving (Show, Read, Eq, Ord, Typeable, Generic)++type RelativeURI =+  (Maybe RelativePath, Maybe Query, Maybe Fragment)++type Authority =+  Either Domain IP++data Scheme = +  HTTP | HTTPS +  deriving (Show, Read, Eq, Ord, Enum, Bounded, Typeable, Generic)++type Domain = +  BS++type IP = +  BS++type Port = +  Int++type RelativePath = +  BS++type Query = +  BS++type Fragment = +  BS
+ library/Wobsurv/Util/HTTP/Parser.hs view
@@ -0,0 +1,101 @@+module Wobsurv.Util.HTTP.Parser where++import BasePrelude hiding (takeWhile, isSpace)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Data.Attoparsec.ByteString.Char8+import Wobsurv.Util.HTTP.Model+import qualified Data.ByteString as ByteString+import Data.ByteString (ByteString)+++type UnknownHeader = (ByteString, ByteString)++labeling :: String -> Parser a -> Parser a+labeling n p = +  p <?> n++head :: Parser (Method, RelativeURI, Version, [UnknownHeader])+head = +  labeling "head" $ +    (,,,) <$> +      (method <* space) <*> (relativeURI <* space) <*>+      (version <* endOfLine) <*> (many unknownHeader <* endOfLine)++method :: Parser Method+method =+  labeling "method" $+    (Left <$> standardMethod) <|> (Right <$> takeWhile isAlpha)++standardMethod :: Parser StandardMethod+standardMethod = +  labeling "standardMethod" $+    p "OPTIONS" Options <|>+    p "GET" Get <|>+    p "HEAD" Head <|>+    p "POST" Post <|>+    p "PUT" Put <|>+    p "DELETE" Delete <|>+    p "TRACE" Trace <|>+    p "CONNECT" Connect +  where+    p n m = +      string n *> pure m++version :: Parser Version+version =+  labeling "version" $+    (,) <$> (string "HTTP/" *> decimal) <*> (char '.' *> decimal)++relativeURI :: Parser RelativeURI+relativeURI =+  labeling "relativeURI" $+    (,,) <$> path <*> optional query <*> optional fragment+  where+    path = +      char '/' *> optional (takeWhile1 (\c -> c /= '?' && not (isSpace c)))+    query = +      char '?' *> takeWhile (\c -> c /= '#' && not (isSpace c))+    fragment = +      char '#' *> takeWhile (not . isSpace)++header :: Parser Header+header =+  labeling "header" $+    (ConnectionHeader <$> connectionHeader) <|> +    (ContentLengthHeader <$> contentLengthHeader) <|>+    (ContentTypeHeader <$> contentTypeHeader) <|> +    (KeepAliveHeader <$> keepAliveHeader)++connectionHeader :: Parser ConnectionHeader+connectionHeader =+  labeling "connectionHeader" $+    string "Connection: " *> (keepAlive <|> close)+  where+    keepAlive = string "keep-alive" *> pure True+    close = string "close" *> pure False++contentLengthHeader :: Parser ContentLengthHeader+contentLengthHeader =+  labeling "contentLengthHeader" $+    string "Content-Length: " *> decimal++contentTypeHeader :: Parser ContentTypeHeader+contentTypeHeader =+  labeling "contentTypeHeader" $+    undefined++keepAliveHeader :: Parser KeepAliveHeader+keepAliveHeader =+  labeling "keepAliveHeader" $+    undefined++unknownHeader :: Parser UnknownHeader+unknownHeader =+  labeling "unknownHeader" $+    (,) <$> (key <* char ':' <* skipSpace) <*> value <* endOfLine+  where+    key = takeWhile1 (\c -> isAlphaNum c || c == '-')+    value = takeWhile1 (/= '\n')++
+ library/Wobsurv/Util/HTTP/Renderer.hs view
@@ -0,0 +1,112 @@+module Wobsurv.Util.HTTP.Renderer where++import BasePrelude+import Control.Monad.Trans.Writer+import Data.ByteString.Builder+import Wobsurv.Util.HTTP.Model+import qualified Pipes+import qualified Pipes.ByteString+import qualified Data.ByteString+import qualified Data.ByteString.Lazy+++toProducer :: Monad m => Builder -> Pipes.Producer BS m ()+toProducer =+  Pipes.ByteString.fromLazy . toLazyByteString++toByteString :: Builder -> Data.ByteString.ByteString+toByteString =+  Data.ByteString.Lazy.toStrict . toLazyByteString++newLine :: Builder+newLine =+  string7 "\r\n"++statusLine :: Version -> Status -> Builder+statusLine versionV statusV =+  version versionV <> char7 ' ' <> status statusV <> newLine++relativeURI :: RelativeURI -> Builder+relativeURI (path, query, fragment) =+  execWriter $ do+    tell $ char7 '/'+    traverse_ (tell . byteString) path+    traverse_ (tell . (char7 '?' <>) . byteString) query+    traverse_ (tell . (char7 '#' <>) . byteString) fragment++version :: Version -> Builder =+  \(major, minor) ->+    string7 "HTTP/" <> wordDec major <> char7 '.' <> wordDec minor++status :: Status -> Builder+status (code, message) =+  wordDec code <> char7 ' ' <> byteString message++headers :: [Header] -> Builder+headers =+  mconcat . map header++header :: Header -> Builder+header =+  \case+    ConnectionHeader x -> connectionHeader x+    ContentLengthHeader x -> contentLengthHeader x+    ContentTypeHeader x -> contentTypeHeader x+    KeepAliveHeader x -> keepAliveHeader x++connectionHeader :: ConnectionHeader -> Builder+connectionHeader keepAlive =+  string7 "Connection: " <> +  string7 (if keepAlive then "keep-alive" else "close") <>+  newLine++contentLengthHeader :: ContentLengthHeader -> Builder+contentLengthHeader length =+  string7 "Content-Length: " <> wordDec length <> newLine++contentTypeHeader :: ContentTypeHeader -> Builder+contentTypeHeader (mimeType, charsetV) =+  string7 "Content-Type: " <> fields <> newLine+  where+    fields =+      mconcat $ intersperse ";" $ catMaybes $+        [ Just (byteString mimeType), +          charsetField <$> charsetV ] +      where+        charsetField x =+          string7 "charset=" <> charset x++keepAliveHeader :: KeepAliveHeader -> Builder+keepAliveHeader (timeout, max) =+  string7 "Keep-Alive: " <> fields <> newLine+  where+    fields =+      mconcat $ intersperse ", " $ catMaybes $+        [ Just $ timeoutField $ timeout, +          maxField <$> max ]+      where+        timeoutField x =+          string7 "timeout=" <> wordDec x+        maxField x =+          string7 "max=" <> wordDec x++charset :: Charset -> Builder+charset =+  \case+    UTF8 -> "utf-8"++method :: Method -> Builder+method =+  either standardMethod byteString++standardMethod :: StandardMethod -> Builder+standardMethod = +  \case+    Options -> string7 "OPTIONS"+    Get     -> string7 "GET"+    Head    -> string7 "HEAD"+    Post    -> string7 "POST"+    Put     -> string7 "PUT"+    Delete  -> string7 "DELETE"+    Trace   -> string7 "TRACE"+    Connect -> string7 "CONNECT"
+ library/Wobsurv/Util/HTTP/URLEncoding.hs view
@@ -0,0 +1,28 @@+module Wobsurv.Util.HTTP.URLEncoding where++import BasePrelude+import Data.Text (Text)+import Data.ByteString (ByteString)+import Filesystem.Path (FilePath)+import qualified Network.HTTP.Types.URI as URI+import qualified Data.Text.Encoding as Text.Encoding+import qualified Filesystem.Path.Rules as Path.Rules+++toText :: ByteString -> Text+toText = +  Text.Encoding.decodeUtf8 . URI.urlDecode True++toFilePath :: ByteString -> FilePath+toFilePath =+  Path.Rules.decode Path.Rules.posix . URI.urlDecode True++fromText :: Text -> ByteString+fromText =+  URI.urlEncode True . Text.Encoding.encodeUtf8++fromFilePath :: FilePath -> ByteString+fromFilePath =+  URI.urlEncode True . Path.Rules.encode Path.Rules.posix++
+ library/Wobsurv/Util/MasterThread.hs view
@@ -0,0 +1,80 @@+module Wobsurv.Util.MasterThread where++import BasePrelude hiding (forkFinally)+import Control.Monad.Trans.Reader+import qualified BasePrelude+import qualified STMContainers.Set as Set+import qualified Wobsurv.Util.PartialHandler as H++-- |+-- A monad, which adds a functionality of forking of slave threads,+-- while binding them to their master thread in such a manner+-- that when the master is killed, they get killed too.+-- It also rethrows exceptions from the slave threads in the main thread,+-- so they don't get lost.+type MasterThread =+  ReaderT Context IO++type Context =+  (Set.Set ThreadId)++type MT = +  MasterThread++run :: MT a -> IO a+run mt =+  do+    context <- atomically $ Set.new+    catch (runReaderT mt context) $ \(e :: SomeException) -> do+      -- Kill all slaves+      traverse_ killThread =<< do+        atomically $ Set.foldM (\l -> return . (: l)) [] context+      -- Wait for all slaves to die+      atomically $ Set.null context >>= bool retry (return ())+      throwIO e++forkFinally :: MT () -> IO () -> MT ThreadId+forkFinally main finalizer =+  ReaderT $ \context -> do+    thread <- myThreadId+    slaveContext <- atomically $ Set.new+    let+      onDeath r =+        do+          -- Finalization and rethrowing of exceptions into the master thread:+          do+            r' <- try $ finalizer+            forM_ (left r <|> left r') $ +              H.toTotal $ H.onThreadKilled (return ()) <> H.rethrowTo thread+          -- Context management:+          do+            traverse_ killThread =<< do+              atomically $ Set.foldM (\l -> return . (: l)) [] slaveContext+            slaveThread <- myThreadId+            -- Ensures that it waits for all slaves to die +            -- before informing the master that it died itself.+            -- And so on recursively.+            atomically $ do+              Set.null slaveContext >>= \case+                True -> Set.delete slaveThread context+                False -> retry+        where+          left = either Just (const Nothing)+    slaveThread <- BasePrelude.forkFinally (runReaderT main slaveContext) onDeath+    atomically $ Set.insert slaveThread context+    return slaveThread++fork :: MT () -> MT ThreadId+fork main =+  forkFinally main (return ())++-- | +-- Run the 'MasterThread' monad, which performs no subforking.+runWithoutForking :: MT a -> IO a+runWithoutForking mt =+  runReaderT mt (error "Attempt to fork when run with 'runWithoutForking'")+++++
+ library/Wobsurv/Util/Mustache/Renderer.hs view
@@ -0,0 +1,84 @@+module Wobsurv.Util.Mustache.Renderer where++import BasePrelude+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except+import Control.Monad.Trans.State+import qualified Data.ByteString+import qualified Data.HashMap.Strict as HashMap+import qualified Data.Text+import qualified Data.Text.Lazy+import qualified Filesystem+import qualified Filesystem.Path.CurrentOS as Path+import qualified Text.Hastache+import qualified Text.Hastache.Context+++type BS =+  Data.ByteString.ByteString++type Text =+  Data.Text.Text++type LazyText =+  Data.Text.Lazy.Text++type Path =+  Path.FilePath++-- |+-- A fast Hastache renderer, +-- which preloads all templates instead of reading them during each rendering.+type Renderer =+  TemplatesCache++-- |+-- Mappings from template names to their contents+-- stored in RAM for faster processing.+-- +-- Supposed to be loaded once during the initialization of the app.+type TemplatesCache =+  HashMap.HashMap TemplateName Text++type TemplateName =+  Text++type Context =+  HashMap.HashMap Text Value++data Value where+  Variable :: Text.Hastache.MuVar a => a -> Value+  Contexts :: [Context] -> Value+++-- |+-- Initialize a renderer by loading all templates from the specified folder.+new :: Path -> IO Renderer+new path =+  initTemplatesCache+  where+    initTemplatesCache =+      flip execStateT mempty $ do+        subpaths <- lift $ Filesystem.listDirectory path+        forM_ subpaths $ \subpath -> do+          contents <- lift $ Filesystem.readTextFile subpath+          modify $ HashMap.insert (fromString $ Path.encodeString $ Path.basename subpath) contents ++-- |+-- Workarounds over Hastache API to enable it with caching.+render :: (Data model) => model -> TemplateName -> Renderer -> Maybe LazyText+render model name cache =+  do+    template <- HashMap.lookup name cache+    return $ unsafePerformIO $ +      Text.Hastache.hastacheStr config template context+  where+    config =+      Text.Hastache.MuConfig Text.Hastache.htmlEscape Nothing Nothing getTemplate+      where+        getTemplate s = +          return $ HashMap.lookup (fromString s) cache+    context =+      Text.Hastache.Context.mkGenericContext model+
+ library/Wobsurv/Util/OpenServer/Connection.hs view
@@ -0,0 +1,57 @@+module Wobsurv.Util.OpenServer.Connection where++import BasePrelude hiding (Interrupted)+import Pipes+import Pipes.Safe hiding (handle)+import Control.Monad.Trans.Except+import Control.Monad.Trans.State+import Control.Monad.Trans.Maybe+import qualified Data.ByteString as ByteString+import qualified Network.Socket as Socket+import qualified Pipes.Network.TCP as PipesNetwork+++type Timeout = +  Int++type BS =+  ByteString.ByteString+++type Interactor = +  Producer BS (SafeT IO) () -> Producer BS (SafeT IO) (Maybe Word)++session :: Timeout -> Interactor -> Socket.Socket -> IO ()+session initTimeout interactor socket =+  handlingExceptions $ runSafeT $ runEffect $ loop initTimeout+  where+    loop timeout = +      do+        nextTimeout <- interactor request >-> response+        traverse_ (loop . fromIntegral) nextTimeout+      where+        request = +          PipesNetwork.fromSocketTimeout timeout socket 4096+        response = +          PipesNetwork.toSocketTimeout timeout socket+++type Rejector = +  Producer BS (SafeT IO) ()++rejection :: Timeout -> Rejector -> Socket.Socket -> IO ()+rejection timeout rejector socket =+  handlingExceptions $ runSafeT $ runEffect $ do+    -- Consume something to keep linux clients happy:+    next $ PipesNetwork.fromSocketTimeout 500000 socket 512+    rejector >-> PipesNetwork.toSocketTimeout timeout socket+++handlingExceptions :: IO () -> IO ()+handlingExceptions =+  handle $ \e -> +    case ioeGetErrorType e of+      ResourceVanished -> return ()+      TimeExpired -> return ()+      _ -> error $ "Wobsurv.Util.OpenServer.Connection.handlingExceptions: Unexpected IOException: " <> show e+
+ library/Wobsurv/Util/OpenServer/ConnectionsManager.hs view
@@ -0,0 +1,55 @@+module Wobsurv.Util.OpenServer.ConnectionsManager where++import BasePrelude+import Control.Monad.Trans.Control+import Control.Monad.Trans.Class+import qualified Data.Text as Text+import qualified Network.Socket as Network+import qualified Network.Simple.TCP as Network.Simple+import qualified Wobsurv.Util.PartialHandler as Handler+import qualified Wobsurv.Util.MasterThread as MT+++-- |+-- Settings for running the server.+data Settings =+  Settings {+    -- |+    -- A port to listen on.+    port :: Word,+    -- | +    -- A maximum amount of clients.+    -- When this amount is reached the server rejects all the further connections.+    connectionsLimit :: Word,+    -- |+    -- A connection socket handler, +    -- which is triggered for connections, +    -- which do not exceed the limit.+    allowedConnectionHandler :: Network.Socket -> MT.MT (),+    -- |+    -- A connection socket handler, +    -- which is triggered for connections, +    -- which do exceed the limit.+    disallowedConnectionHandler :: Network.Socket -> MT.MT ()+  }++listen :: Settings -> MT.MT ()+listen settings =+  liftBaseWith $ \unlift -> do+    Network.Simple.listen Network.Simple.HostAny (show (port settings)) $ \(socket, address) -> do+      availableSlotsVar <- newMVar (connectionsLimit settings)+      forever $ do+        socket' <- fst <$> Network.accept socket+        let+          handler = +            liftBaseWith $ \unlift -> do+              void $ join $ modifyMVar availableSlotsVar $ \availableSlots -> +                if availableSlots > 0+                  then return (pred availableSlots, unlift $ allowedConnectionHandler settings socket')+                  else return (availableSlots, unlift $ disallowedConnectionHandler settings socket')+          releaser = +            do+              Network.close socket'+              modifyMVar_ availableSlotsVar $ return . succ+        unlift $ MT.forkFinally handler releaser+
+ library/Wobsurv/Util/PartialHandler.hs view
@@ -0,0 +1,65 @@+module Wobsurv.Util.PartialHandler where++import BasePrelude+++-- |+-- A composable exception handler.+newtype PartialHandler a =+  PartialHandler (SomeException -> Maybe (IO a))+++instance Monoid (PartialHandler a) where+  mempty = +    PartialHandler $ const Nothing+  mappend (PartialHandler h1) (PartialHandler h2) =+    PartialHandler $ \e -> h1 e <|> h2 e+++-- |+-- Construct from a typed handler.+typed :: Exception e => (e -> Maybe (IO a)) -> PartialHandler a+typed h =+  PartialHandler $ \e -> +    case fromException e of+      Just e' -> h e'+      Nothing -> Nothing+++-- |+-- Convert a partial handler into a total "SomeException" handler,+-- which rethrows exceptions for unhandled cases.+toTotal :: PartialHandler a -> (SomeException -> IO a)+toTotal (PartialHandler h) =+  \e -> fromMaybe (throwIO e) (h e)+++-- * Standard handlers+-------------------------++onThreadKilled :: IO a -> PartialHandler a+onThreadKilled io =+  typed $ \case+    ThreadKilled -> Just io+    _ -> Nothing++-- |+-- A handler which rethrows all exceptions to the specified thread.+rethrowTo :: ThreadId -> PartialHandler ()+rethrowTo t =+  PartialHandler $ \e -> Just (throwTo t e)+++-- * Utils+-------------------------++-- |+-- Like 'forkFinally' but rethrows all unhandled exceptions to the parent thread.+forkFinallyRethrowing :: IO () -> PartialHandler () -> IO () -> IO ThreadId+forkFinallyRethrowing performer handler releaser =+  do+    t <- myThreadId+    forkFinally performer $ \r -> do+      releaser+      either (toTotal (handler <> rethrowTo t)) return r+
+ library/Wobsurv/Util/PipesAttoparsec.hs view
@@ -0,0 +1,56 @@+-- |+-- Utils for integration of Pipes and Attoparsec.+module Wobsurv.Util.PipesAttoparsec where++import BasePrelude+import Pipes.Parse hiding (execStateT, evalStateT)+import Control.Monad.Trans.State+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec+import qualified Data.ByteString as BS+++type BS = +  BS.ByteString++type AttoParser =+  Attoparsec.Parser++type PipesParser m r =+  Parser BS m r++data Error =+  UnfinishedInput |+  ConsumedTooMuch |+  AttoparsecError ![String] !String+  deriving (Show)+++liftParserWithLimit :: (Monad m) => Int -> AttoParser a -> PipesParser m (Either Error a)+liftParserWithLimit limit parser =+  evalStateT (loop initCont) limit+  where+    loop cont =+      do+        chunk <- return . fromMaybe BS.empty =<< lift draw+        modify (subtract (BS.length chunk))+        n <- get+        if n < 0+          then +            return $ Left $ ConsumedTooMuch+          else+            case cont chunk of+              Attoparsec.Fail remainder context message -> +                do+                  lift $ unDraw remainder+                  return $ Left $ AttoparsecError context message+              Attoparsec.Partial cont' -> +                if BS.length chunk > 0+                  then loop cont'+                  else return $ Left $ UnfinishedInput+              Attoparsec.Done remainder result -> +                do+                  lift $ unDraw remainder+                  return $ Right result+    initCont =+      Attoparsec.parse parser+
+ library/Wobsurv/Util/WorkerThread.hs view
@@ -0,0 +1,23 @@+module Wobsurv.Util.WorkerThread where++import BasePrelude hiding (fork)+import Wobsurv.Util.MasterThread+import Control.Concurrent.STM.TBQueue+import Control.Monad.Trans.Class+++type WorkerThread =+  TBQueue (MT ())++new :: Int -> MT WorkerThread+new size =+  do+    queue <- lift $ atomically $ newTBQueue size+    fork $ do+      forever $ join $ lift $ atomically $ readTBQueue queue+    return queue++schedule :: MT () -> WorkerThread -> MT ()+schedule task queue =+  lift $ atomically $ writeTBQueue queue task+
+ tests/Main.hs view
@@ -0,0 +1,254 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}+module Main where++import Test.Framework+import BasePrelude hiding (getEnv)+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.Text (Text)+import Data.ByteString (ByteString)+import Filesystem.Path.CurrentOS (FilePath)+import qualified Control.Concurrent.Async.Lifted as Async+import qualified Network+import qualified Network.HTTP.Client as Client+import qualified Wobsurv+import qualified Filesystem+import qualified Data.Text+import qualified Data.Text.Encoding+import qualified Data.ByteString.Lazy+import qualified Data.ByteString as ByteString+import qualified Network.HTTP.Types.Status+import qualified Filesystem.Path.CurrentOS+import qualified System.Random.MWC as MWC+++type LazyByteString =+  Data.ByteString.Lazy.ByteString++main = +  Network.withSocketsDo $ htfMain htf_thisModulesTests+++-- * Tests+-------------------------++test_notFound =+  runTest env1 $ do+    status <- getResponseStatus =<< resourceURI =<< missingResource+    lift $ assertEqual "Not Found" status++test_ok =+  runTest env1 $ do+    response <- getResponse =<< resourceURI =<< existentResource+    lift $ assertEqual "OK" $ responseStatus response+    lift $ assertBool $ (/= "") $ responseBody response++test_corruptRequestsDontMakeTheServerThrowExceptions =+  unitTestPending ""++test_corruptRequestsDontReduceTheConnectionSlots =+  unitTestPending ""++test_highLoad =+  runTest (env1 {envConnectionsLimit = 48}) $ do+    results <-+      Async.mapConcurrently id $ replicate 48 $ do+        replicateM 5 $ +          getResponseStatus =<< resourceURI =<< someResource+    lift $ assertBool $ all (/= "Service Unavailable") $ concat $ results++test_tooManyConnections =+  runTest (env1 {envConnectionsLimit = 10}) $ do+    results <- +      Async.mapConcurrently id $ replicate 20 $ do+        getResponseStatus =<< resourceURI =<< largeResource+    lift $ assertBool $ (> 1) $ length $ filter (== "Service Unavailable") $ results++test_multipleClientsOnTooManyConnectionsStillGetDismissedProperly =+  test_tooManyConnections++test_slotsGetReleased =+  runTest (env1 {envConnectionsLimit = 10}) $ do+    Async.mapConcurrently id $ replicate 20 $ do+      getResponseStatus =<< resourceURI =<< someResource+    results <- +      Async.mapConcurrently id $ replicate 10 $ do+        getResponseStatus =<< resourceURI =<< someResource+    lift $ assertBool $ all (/= "Service Unavailable") $ results++test_uriDecoding =+  runTest env1 $ do+    let path = "Директория/Название в Юникоде с пробелами.расширение"+    createFile 1 path+    lift . assertEqual "OK" =<< getResponseStatus =<< resourceURI path+++-- * Test monad+-------------------------++type Test =+  ReaderT Setup IO++type Setup =+  (Client.Manager, ThreadId, Env, MWC.GenIO)++runTest :: Env -> Test a -> IO a+runTest env test =+  bracket acquire release $ runReaderT test+  where+    acquire =+      do+        manager <- Client.newManager Client.defaultManagerSettings+        serverThread <- +          forkIO $ Wobsurv.serve $ +            Wobsurv.Settings+              (True)+              (envPort env) +              (envConnectionsLimit env) +              ("templates")+              (envRoot env)+              (mempty)+        traverse_ (prepFile 10000) (envSmallFiles env)+        traverse_ (prepFile 1000000) (envLargeFiles env)+        rand <- MWC.create+        return (manager, serverThread, env, rand)+      where+        prepFile size path =+          do+            Filesystem.createTree (Filesystem.Path.CurrentOS.directory fullPath)+            Filesystem.writeFile fullPath $ +              ByteString.replicate size (fromIntegral $ ord 'x')+          where+            fullPath = envRoot env <> path+    release (manager, serverThread, env, rand) =+      do+        Client.closeManager manager+        killThread serverThread+        Filesystem.removeTree (envRoot env)++createFile :: Int -> FilePath -> Test ()+createFile size path =+  do+    fullPath <- (<> path) . envRoot <$> getEnv+    lift $ do+      Filesystem.createTree (Filesystem.Path.CurrentOS.directory fullPath)+      Filesystem.writeFile fullPath $ +        ByteString.replicate size (fromIntegral $ ord 'x')++-- | Send a "GET" request.+getResponse :: URI -> Test Response+getResponse uri =+  do+    (manager, _, _, _) <- ask+    request <- Client.parseUrl uri+    lift $ Client.httpLbs request manager++getResponseStatus :: URI -> Test Status+getResponseStatus uri =+  do+    (manager, _, _, _) <- ask+    request <- Client.parseUrl uri+    lift $ fmap Network.HTTP.Types.Status.statusMessage $ handle getHTTPExceptionStatus $ +      Client.responseStatus <$> Client.httpLbs request manager+  where+    getHTTPExceptionStatus =+      \case+        Client.StatusCodeException s _ _ -> return s+        e -> throwIO e++random :: MWC.Variate a => (a, a) -> Test a+random range =+  do+    (_, _, _, gen) <- ask+    lift $ MWC.uniformR range gen++oneOf :: [a] -> Test (Maybe a)+oneOf list =+  case length list of+    0 -> return Nothing+    l -> do+      i <- random (0, pred l)+      return $ Just $ list !! i++someResource :: Test FilePath+someResource =+  random (0 :: Int, 1) >>= \case+    0 -> missingResource+    1 -> existentResource++getEnv :: Test Env+getEnv =+  ReaderT $ \(_, _, x, _) -> return x++largeResource :: Test FilePath+largeResource =+  return . fromMaybe (error "No large files") =<< oneOf . envLargeFiles =<< getEnv++smallResource :: Test FilePath+smallResource =+  return . fromMaybe (error "No small files") =<< oneOf . envSmallFiles =<< getEnv++missingResource :: Test FilePath+missingResource =+  return . fromMaybe (error "No missing files") =<< oneOf . envMissingFiles =<< getEnv++existentResource :: Test FilePath+existentResource =+  random (0 :: Int, 1) >>= \case+    0 -> smallResource+    1 -> largeResource++responseStatus :: Response -> Status+responseStatus =+  Network.HTTP.Types.Status.statusMessage . Client.responseStatus++responseBody :: Response -> LazyByteString+responseBody =+  Client.responseBody++resourceURI :: FilePath -> Test URI+resourceURI path = do+  (_, _, env, _) <- ask+  return $ +    "http://localhost:" <> show (envPort env) <> "/" <> pathString+  where+    pathString =+      Filesystem.Path.CurrentOS.encodeString path++type Response =+  Client.Response LazyByteString++type URI =+  [Char]++type Status =+  ByteString+++-- ** Predefined environments+-------------------------++data Env =+  Env {+    envPort :: Word,+    envConnectionsLimit :: Word,+    envRoot :: FilePath,+    envLargeFiles :: [FilePath],+    envSmallFiles :: [FilePath],+    envMissingFiles :: [FilePath]+  }++env1 :: Env+env1 =+  Env 53000 10 root largeFiles smallFiles missingFiles+  where+    root = +      "dist/wobsurv-test-tmp/"+    smallFiles = +      [ "a.txt", "dir/b.txt", "Ёжик лижет мёд.jpg" ]+    largeFiles = +      [ "c.mp3", "d/d d d" ]+    missingFiles =+      [ "e.txt", "f.nfo" ]++
+ wobsurv.cabal view
@@ -0,0 +1,183 @@+name:+  wobsurv+version:+  0.1.0+synopsis:+  A simple and highly performant HTTP file server+description:+  Notable features:+  .+  * Based on streaming. Produces the response while the request is still coming. It doesn't waste resources on incorrect or malicious requests by dismissing them right away. It is very gentle with memory.+  .+  * Has a configurable limit of simultaneous connections. All exceeding requests get rejected with a "Service Unavailable" status with code 503.+category:+  Network, Networking, Service+homepage:+  https://github.com/nikita-volkov/wobsurv +bug-reports:+  https://github.com/nikita-volkov/wobsurv/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2014, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10+++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/wobsurv.git+++library+  hs-source-dirs:+    library+  other-modules:+    Wobsurv.Interaction+    Wobsurv.Logging+    Wobsurv.RequestHeaders+    Wobsurv.Response+    Wobsurv.TemplateModels.Index+    Wobsurv.TemplateModels.NotFound+    -- * Things that could be extracted into external libraries:+    -- ** A wrapper library over "hastache"+    Wobsurv.Util.Mustache.Renderer+    -- ** A basic implementation of the HTTP protocol+    Wobsurv.Util.HTTP.Model+    Wobsurv.Util.HTTP.Parser+    Wobsurv.Util.HTTP.Renderer+    Wobsurv.Util.HTTP.URLEncoding+    -- ** A bound thread hierarchies management+    Wobsurv.Util.MasterThread+    -- ** A protocol-agnostic request-response server+    Wobsurv.Util.OpenServer.Connection+    Wobsurv.Util.OpenServer.ConnectionsManager+    -- ** A composable exceptions handler+    Wobsurv.Util.PartialHandler+    -- ** Integration of "attoparsec" with "pipes"+    Wobsurv.Util.PipesAttoparsec+    -- ** A task performer thread, +    -- which allows to execute sequential tasks in a non-blocking way.+    Wobsurv.Util.WorkerThread+  exposed-modules:+    Wobsurv+  build-depends:+    -- file-system:+    system-filepath == 0.4.*,+    system-fileio == 0.3.*,+    -- network:+    network == 2.5.*,+    network-simple == 0.4.*,+    http-types == 0.8.*,+    pipes-network == 0.6.*,+    -- streaming:+    pipes == 4.1.*,+    pipes-parse == 3.0.*,+    pipes-bytestring == 2.1.*,+    pipes-text == 0.0.*,+    pipes-safe == 2.2.*,+    -- rendering:+    hastache == 0.6.*,+    -- parsing:+    attoparsec == 0.12.*,+    -- data:+    stm-containers == 0.1.*,+    old-locale == 1.0.*,+    time == 1.4.*,+    text >= 1.1.1.3 && < 1.3,+    bytestring >= 0.10.4.0 && < 0.11,+    unordered-containers == 0.2.*,+    -- general:+    stm == 2.4.*,+    monad-control == 0.3.*,+    transformers == 0.4.*,+    base-prelude >= 0.1.5 && < 0.2+  ghc-options:+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+++executable wobsurv+  hs-source-dirs:   +    wobsurv+  main-is:     +    Main.hs+  build-depends:+    wobsurv,+    -- file-system:+    system-filepath == 0.4.*,+    system-fileio == 0.3.*,+    -- network:+    network == 2.5.*,+    -- data:+    yaml == 0.8.*,+    aeson == 0.8.*,+    text >= 1.1.1.3 && < 1.3,+    bytestring >= 0.10.4.0 && < 0.11,+    unordered-containers == 0.2.*,+    -- general:+    safe == 0.3.*,+    base-prelude >= 0.1.5 && < 0.2+  ghc-options:+    -threaded+    "-with-rtsopts=-N"+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+++test-suite tests+  type:             +    exitcode-stdio-1.0+  hs-source-dirs:   +    tests+  main-is:          +    Main.hs+  build-depends:+    wobsurv,+    -- testing:+    HTF == 0.12.*,+    quickcheck-instances == 0.3.*,+    QuickCheck == 2.7.*,+    HUnit == 1.2.*,+    -- file-system:+    system-filepath == 0.4.*,+    system-fileio == 0.3.*,+    -- network:+    network == 2.5.*,+    http-client == 0.3.*,+    http-types == 0.8.*,+    -- data:+    text >= 1.1.1.3 && < 1.3,+    bytestring >= 0.10.4.0 && < 0.11,+    -- concurrency:+    lifted-async == 0.2.*,+    -- randomness:+    mwc-random == 0.13.*,+    -- general:+    safe == 0.3.*,+    transformers == 0.4.*,+    base-prelude >= 0.1.5 && < 0.2+  ghc-options:+    -threaded+    "-with-rtsopts=-N"+    -funbox-strict-fields+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010
+ wobsurv/Main.hs view
@@ -0,0 +1,55 @@+module Main where++import BasePrelude+import Safe+import Data.Text (Text)+import Data.ByteString (ByteString)+import Filesystem.Path (FilePath)+import Data.Aeson ((.:), (.:?), (.!=))+import qualified Data.Yaml as Yaml+import qualified Data.Aeson.Types as Aeson+import qualified Data.ByteString as ByteString+import qualified Data.Text.Encoding as Text.Encoding+import qualified Filesystem+import qualified Filesystem.Path.CurrentOS as FilePath+import qualified Wobsurv+import qualified Network+++main :: IO ()+main = +  Network.withSocketsDo $ do+    portArg <- fmap read . headMay <$> getArgs+    settings <-+      loadSettings >>= \case+        Left e -> do+          putStrLn $ "Config error: " <> e+          exitFailure+        Right s -> +          return $ maybe s (\x -> s {Wobsurv.port = x}) portArg+    Wobsurv.serve settings++loadSettings :: IO (Either String Wobsurv.Settings)+loadSettings =+  do+    Just json <- Yaml.decodeFile "config.yaml"+    return $ Aeson.parseEither settingsParser json++settingsParser :: Aeson.Object -> Aeson.Parser Wobsurv.Settings+settingsParser o =+  do+    logging          <- o .:? "logging" .!= True+    port             <- o .:? "default-port" .!= 53000+    connectionsLimit <- o .:? "connections-limit" .!= 48+    templatesDir     <- filePath =<< o .:? "templates-dir" .!= "templates"+    contentDir       <- filePath =<< o .:? "content-dir" .!= "www"+    mimeMappings     <- traverse byteString =<< o .:? "mime-types" .!= mempty+    return $ +      Wobsurv.Settings logging port connectionsLimit templatesDir contentDir mimeMappings+  where+    filePath = +      Aeson.withText "FilePath" $ pure . FilePath.fromText+    byteString =+      Aeson.withText "ByteString" $ pure . Text.Encoding.encodeUtf8++