packages feed

salvia-extras 0.1.2 → 1.0.0

raw patch · 11 files changed

+764/−86 lines, 11 filesdep +HStringTemplatedep +bytestringdep +c10kdep ~basedep ~fclabelsdep ~hscolour

Dependencies added: HStringTemplate, bytestring, c10k, filestore, monads-fd, network, old-locale, pureMD5, salvia-protocol, sendfile, split, stm, text, threadmanager, time, transformers, utf8-string

Dependency ranges changed: base, fclabels, hscolour, salvia

Files

salvia-extras.cabal view
@@ -1,7 +1,7 @@ Name:             salvia-extras-Version:          0.1.2-Description:      Collection of non-fundamental request handler for the Salvia web server.-Synopsis:         Collection of non-fundamental request handler for the Salvia web server.+Version:          1.0.0+Description:      Collection of non-fundamental handlers for the Salvia web server.+Synopsis:         Collection of non-fundamental handlers for the Salvia web server. Category:         Network, Web License:          BSD3 License-file:     LICENSE@@ -9,14 +9,42 @@ Maintainer:       sfvisser@cs.uu.nl Cabal-version:    >= 1.6 Build-Type:       Simple-Build-Depends:    base ==3.0.*,-                  fclabels ==0.1.*,-                  clevercss ==0.1.*,-                  hscolour ==1.11.*,-                  salvia ==0.1.*-GHC-Options:      -Wall-HS-Source-Dirs:   src-Exposed-modules:  Network.Salvia.Handler.CleverCSS,-                  Network.Salvia.Handler.ExtendedFileSystem,-                  Network.Salvia.Handler.HsColour++Library+  GHC-Options:      -Wall+  HS-Source-Dirs:   src++  Build-Depends:    base ==4.*,+                    clevercss ==0.1.*,+                    bytestring ==0.9.*,+                    salvia ==1.0.*,+                    salvia-protocol ==1.0.*,+                    transformers ==0.1.*,+                    fclabels ==0.4.*,+                    hscolour ==1.15.*,+                    text >= 0.5 && < 0.8,+                    old-locale ==1.0.*,+                    time ==1.1.*,+                    filestore ==0.3.*,+                    network >= 2.2.1.7 && < 2.3,+                    monads-fd ==0.0.*,+                    stm ==2.1.*,+                    HStringTemplate ==0.6.*,+                    sendfile ==0.6.*,+                    utf8-string ==0.3.*,+                    c10k ==0.2.0,+                    pureMD5 ==1.0.*,+                    split ==0.1.*,+                    threadmanager ==0.1.*++  Other-Modules:    Util.Terminal+  Exposed-modules:  Network.Salvia.Handler.CleverCSS,+                    Network.Salvia.Handler.ColorLog+                    Network.Salvia.Handler.ExtendedFileSystem,+                    Network.Salvia.Handler.FileStore+                    Network.Salvia.Handler.HsColour+                    Network.Salvia.Handler.SendFile+                    Network.Salvia.Handler.StringTemplate+                    Network.Salvia.Impl.C10k+                    Network.Salvia.Impl.Cgi
src/Network/Salvia/Handler/CleverCSS.hs view
@@ -1,29 +1,28 @@-module Network.Salvia.Handler.CleverCSS (-    hFilterCSS-  , hCleverCSS-  , hParametrizedCleverCSS-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.CleverCSS+( hFilterCSS+, hCleverCSS+, hParametrizedCleverCSS+)+where -import Network.Protocol.Uri (Parameters)-import Network.Salvia.Handler.ExtensionDispatcher (hExtension)-import Network.Salvia.Handler.Fallback (hOr)-import Network.Salvia.Handler.File (hFile, hFileFilter)-import Network.Salvia.Handler.PathRouter (hParameters)-import Network.Salvia.Handler.Rewrite (hRewriteExt)-import Network.Salvia.Httpd (Handler)-import Text.CSS.CleverCSS (cleverCSSConvert)+import Control.Applicative+import Control.Monad.State+import Data.Record.Label hiding (get)+import Network.Protocol.Uri+import Network.Protocol.Http+import Network.Salvia+import Text.CSS.CleverCSS  -hFilterCSS :: Handler () -> Handler () -> Handler ()-hFilterCSS cssfilter handler = do-  hExtension (Just "css")-    (hFile `hOr` cssfilter)-    handler+hFilterCSS :: (MonadIO m, HttpM' m, SendM m, Alternative m) => m () -> m () -> m ()+hFilterCSS css = hExtension (Just "css") (hFile <|> css) -hCleverCSS :: Handler ()-hCleverCSS = hParameters >>= hParametrizedCleverCSS+hCleverCSS :: (MonadIO m, BodyM Request m, HttpM' m, SendM m) => m ()+hCleverCSS = hRequestParameters "utf-8" >>= hParametrizedCleverCSS -hParametrizedCleverCSS :: Parameters -> Handler ()-hParametrizedCleverCSS p = do-  hRewriteExt (fmap ('c':)) (hFileFilter convert)+hParametrizedCleverCSS :: (MonadIO m, HttpM' m, SendM m) => Parameters -> m ()+hParametrizedCleverCSS p =+  do hRewriteExt (fmap ('c':)) (hFileFilter convert)+     response (contentType =: Just ("text/css", Just "utf-8"))   where convert = either id id . flip (cleverCSSConvert "") (map (fmap $ maybe "" id) p)
+ src/Network/Salvia/Handler/ColorLog.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.ColorLog+( Counter (..)+, hCounter+, hColorLog+, hColorLogWithCounter+)+where++import Control.Applicative+import Control.Monad.State+import Data.List+import Data.Record.Label hiding (get)+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime+import Network.Protocol.Http+import Network.Salvia.Interface+import System.IO+import System.Locale+import Util.Terminal++newtype Counter = Counter { unCounter :: Integer }++-- | This handler simply increases the request counter variable.++hCounter :: PayloadM p Counter m => m Counter+hCounter = payload (modify (Counter . (+1) . unCounter) >> get)++{- |+A simple logger that prints a summery of the request information to the+specified file handle.+-}++hColorLog :: (AddressM' m, MonadIO m, HttpM' m) => Handle -> m ()+hColorLog = logger Nothing++-- | Like `hLog` but also prints the request count since server startup.++hColorLogWithCounter :: (PayloadM p Counter m, AddressM' m, MonadIO m, HttpM' m) => Handle -> m ()+hColorLogWithCounter h = hCounter >>= flip logger h . Just++-- Helper functions.++logger :: (AddressM' m, MonadIO m, HttpM' m) => Maybe Counter -> Handle -> m ()+logger mcount h =+  do let count = maybe "-" (show . unCounter) mcount+     mt <- request (getM method)+     ur <- request (getM uri)+     st <- response (getM status)+     ca <- clientAddress+     sa <- serverAddress+     dt <- liftIO $+       do zone <- getCurrentTimeZone+          time <- utcToLocalTime zone <$> getCurrentTime+          return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" time+     liftIO+       . hPutStrLn h+       $ intercalate " ; "+         [ dt+         , show sa+         , count+         , methodToColor mt ++ show mt ++ reset+         , show ca+         , whiteBold ++ ur ++ reset+         , statusToColor st ++ show (codeFromStatus st) +++           " " ++ show st ++ reset+         ]++statusToColor :: Status -> String+statusToColor st =+  case codeFromStatus st of+    c | c <= 199 -> blueBold+      | c <= 299 -> greenBold+      | c <= 399 -> yellowBold+      | c <= 499 -> redBold+    _            -> magentaBold++methodToColor :: Method -> String+methodToColor GET = whiteBold+methodToColor _   = yellowBold+
src/Network/Salvia/Handler/ExtendedFileSystem.hs view
@@ -1,21 +1,36 @@-module Network.Salvia.Handler.ExtendedFileSystem (hExtendedFileSystem) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.ExtendedFileSystem+( hExtendedFileSystemSendFile+, hExtendedFileSystem+) where -import Network.Salvia.Handler.CleverCSS (hFilterCSS, hCleverCSS)-import Network.Salvia.Handler.HsColour (hHighlightHaskell, hHsColour)-import Network.Salvia.Handler.Directory (hDirectoryResource)-import Network.Salvia.Handler.File (hFileResource)-import Network.Salvia.Handler.FileSystem (hFileTypeDispatcher)-import Network.Salvia.Handler.Rewrite (hWithDir)-import Network.Salvia.Httpd (Handler)+import Control.Applicative+import Control.Monad.Trans+import Network.Protocol.Http+import Network.Salvia+import Network.Salvia.Handler.CleverCSS+import Network.Salvia.Handler.HsColour+import Network.Salvia.Handler.SendFile -hExtendedFileSystem :: FilePath -> Handler ()-hExtendedFileSystem dir =-    hFileTypeDispatcher-    hDirectoryResource-  ( \r -> hHighlightHaskell (hHsColour r)-  $ hWithDir dir-  $ hFilterCSS hCleverCSS-  $ hFileResource r)-  dir+hExtendedFileSystemSendFile+  :: (MonadIO m, HttpM' m, SocketQueueM m, SendM m, BodyM Request m, Alternative m)+  => String -> m ()+hExtendedFileSystemSendFile dir = hFileTypeDispatcher hDirectoryResource f dir+  where+  f file = hHighlightHaskell (hHsColour file)+         . hWithDir dir+         . hFilterCSS hCleverCSS+         . hSendFileResource +         $ file +hExtendedFileSystem+  :: (MonadIO m, HttpM' m, SendM m, BodyM Request m, Alternative m)+  => String -> m ()+hExtendedFileSystem dir = hFileTypeDispatcher hDirectoryResource f dir+  where+  f file = hHighlightHaskell (hHsColour file)+         . hWithDir dir+         . hFilterCSS hCleverCSS+         . hFileResource +         $ file
+ src/Network/Salvia/Handler/FileStore.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}+module Network.Salvia.Handler.FileStore (hFileStore, hFileStoreFile, hFileStoreDirectory) where++import Control.Exception+import Control.Monad.Trans+import Data.FileStore+import Data.List (intercalate)+import Data.List.Split+import Data.Record.Label+import Network.Protocol.Http hiding (NotFound)+import Network.Protocol.Uri+import Network.Salvia.Handlers+import Network.Salvia.Interface+import qualified Network.Protocol.Http as Http++-- Top level filestore server.++hFileStore+  :: (MonadIO m, BodyM Request m, HttpM' m, SendM m)+  => FileStore -> Author -> FilePath -> m ()+hFileStore fs author =+  hFileTypeDispatcher+    (hFileStoreDirectory fs)+    (hFileStoreFile fs author)++hFileStoreFile+  :: (MonadIO m, BodyM Request m, HttpM' m, SendM m)+  => FileStore -> Author -> FilePath -> m ()+hFileStoreFile fs author _ =+  do m <- request (getM method)+     u <- request (getM asUri)+     let p = mkRelative (get path u)+         q = get query u+     -- Default content type to text/plain, and override in hLatest+     -- and hRetrieve.+     response (contentType =: Just ("text/plain", Nothing))++     -- REST based routing.+     case (p, m, q) of+       ("index",  GET,    _        ) -> hIndex     fs+       ("search", GET,    _        ) -> hSearch    fs q+       (_,        GET,    "history") -> hHistory   fs p+       (_,        GET,    "latest" ) -> hLatest    fs p+       (_,        GET,    _        ) -> hRetrieve  fs p q+       (_,        PUT,    _        ) -> hSave      fs p q author+       (_,        DELETE, _        ) -> hDelete    fs p q author+       _                             -> hError Http.NotFound++hFileStoreDirectory+  :: (MonadIO m, BodyM Request m, HttpM' m, SendM m)+  => FileStore -> FilePath -> m ()+hFileStoreDirectory fs _ =+  do u <- request (getM asUri)+     let p = mkRelative (get path u)+     run (directory fs p) (intercalate "\n" . map showFS)+  where showFS (FSFile      f) = f+        showFS (FSDirectory d) = d ++ "/"++-- Type class alias.++class    (MonadIO m, BodyM Request m, HttpM' m, SendM m) => F m where+instance (MonadIO m, BodyM Request m, HttpM' m, SendM m) => F m++-- Specific filestore handlers.++hIndex :: F m => FileStore -> m ()+hIndex fs = run (index fs) (intercalate "\n")++hSearch :: F m => FileStore -> String -> m ()+hSearch fs q =+  run (search fs sq) showMatches+  where showMatches = intercalate "\n" . map showMatch+        showMatch (SearchMatch f n l) = intercalate ":" [f, show n, l]+        sq = defaultSearchQuery+               { queryMatchAll   = False+               , queryWholeWords = False+               , queryIgnoreCase = False+               , queryPatterns   = splitOn "&" q+               }++hRetrieve :: F m => FileStore -> FilePath -> String -> m ()+hRetrieve fs p q =+  do response (contentType =: Just (fileMime p, Nothing))+     run (retrieve fs p (if null q then Nothing else Just q)) id++hLatest :: F m => FileStore -> FilePath -> m ()+hLatest fs p =+  do response (contentType =: Just (fileMime p, Nothing))+     run (latest fs p) id++hSave :: F m => FileStore -> FilePath -> Description -> Author -> m ()+hSave fs p q author =+  do b <- hRawRequestBody+     run (save fs p author q b) (const "document saved\n")++hDelete :: F m => FileStore -> FilePath -> Description -> Author -> m ()+hDelete fs p q author = run (delete fs p author q) (const "document deleted\n")++hHistory :: F m => FileStore -> FilePath -> m ()+hHistory fs p =+  run (history fs [p] (TimeRange Nothing Nothing)) showHistory+  where showHistory = intercalate "\n" . map showRevision+        showRevision (Revision i d a s _) = intercalate "," [i, show d, showAuthor a, s]+        showAuthor (Author n e) = n ++ " <" ++ e ++ ">"++-- Helper functions.++run :: F m => IO a -> (a -> String) -> m ()+run action f =+  do e <- liftIO (try action)+     case e of+       Left err  -> hCustomError (mkError err) (show err)+       Right res -> send (f res)++mkError :: FileStoreError -> Status+mkError RepositoryExists     = Http.BadRequest+mkError ResourceExists       = Http.BadRequest+mkError NotFound             = Http.NotFound+mkError IllegalResourceName  = Http.NotFound+mkError Unchanged            = Http.NotFound+mkError UnsupportedOperation = Http.BadRequest+mkError NoMaxCount           = Http.InternalServerError+mkError _                    = Http.BadRequest++mkRelative :: String -> String+mkRelative = dropWhile (=='/')+
src/Network/Salvia/Handler/HsColour.hs view
@@ -1,52 +1,55 @@-module Network.Salvia.Handler.HsColour (-    hHighlightHaskell-  , hHsColour-  , hHsColourCustomStyle--  , defaultStyleSheet-  ) where+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.HsColour+( hHighlightHaskell+, hHsColour+, hHsColourCustomStyle+, defaultStyleSheet+)+where +import Control.Monad.Trans+import Data.List import Data.Record.Label import Language.Haskell.HsColour.CSS-import Network.Protocol.Http (contentType, utf8)+import Network.Protocol.Http+import Network.Salvia.Interface import Network.Salvia.Handlers-import Network.Salvia.Httpd -hHighlightHaskell :: Handler () -> Handler () -> Handler ()+hHighlightHaskell :: HttpM Request m => m a -> m a -> m a hHighlightHaskell highlighter = -  hExtensionRouter [-    (Just "hs",  highlighter)-  , (Just "lhs", highlighter)-  , (Just "ag",  highlighter)-  ]+  hExtensionRouter+    [ (Just "hs",  highlighter) -- Haskell sources.+    , (Just "lhs", highlighter) -- Literate Haskell sources.+    , (Just "ag",  highlighter) -- Attribute grammar files.+    ] -hHsColour :: ResourceHandler ()+hHsColour :: (SendM m, HttpM Response m, MonadIO m) => FilePath -> m () hHsColour = hHsColourCustomStyle (Left defaultStyleSheet) --- Left means direct inclusion of stylesheet, right means link to external+-- | Left means direct inclusion of stylesheet, right means link to external -- stylesheet. -hHsColourCustomStyle :: Either String String -> ResourceHandler ()-hHsColourCustomStyle style r = do-  sendStr (either id makeStyleLink style)-  hFileResourceFilter (hscolour False True "") r-  setM (contentType % response) ("text/html", Just utf8)+hHsColourCustomStyle :: (SendM m, HttpM Response m, MonadIO m) => Either String String -> FilePath -> m ()+hHsColourCustomStyle style file =+  do send (either id makeStyleLink style)+     hFileResourceFilter (hscolour True) file+     response (contentType =: Just ("text/html", Just "utf-8"))  makeStyleLink :: String -> String makeStyleLink css = "<link rel=\"stylesheet\" type=\"text/css\" href=\"" ++ css ++ "\"></link>"  defaultStyleSheet :: String-defaultStyleSheet = filter (/=' ') $ concat [-    "<style>"-  , ".varop      { color : #960; font-weight : normal; }"-  , ".keyglyph   { color : #960; font-weight : normal; }"-  , ".definition { color : #005; font-weight : bold;   }"-  , ".varid      { color : #444; font-weight : normal; }"-  , ".keyword    { color : #000; font-weight : bold;   }"-  , ".comment    { color : #44f; font-weight : normal; }"-  , ".conid      { color : #000; font-weight : normal; }"-  , ".num        { color : #00a; font-weight : normal; }"-  , ".str        { color : #a00; font-weight : normal; }"+defaultStyleSheet = filter (/=' ') $ intercalate "\n"+  [ "<style>"+  , ".hs-varop      { color : #960; font-weight : normal; }"+  , ".hs-keyglyph   { color : #960; font-weight : normal; }"+  , ".hs-definition { color : #005; font-weight : bold;   }"+  , ".hs-varid      { color : #444; font-weight : normal; }"+  , ".hs-keyword    { color : #000; font-weight : bold;   }"+  , ".hs-comment    { color : #44f; font-weight : normal; }"+  , ".hs-conid      { color : #000; font-weight : normal; }"+  , ".hs-num        { color : #00a; font-weight : normal; }"+  , ".hs-str        { color : #a00; font-weight : normal; }"   , "</style>"   , ""   ]
+ src/Network/Salvia/Handler/SendFile.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.SendFile (hSendFileResource) where++import Control.Monad.Trans+import Data.Record.Label+import Network.Protocol.Http+import Network.Salvia+import Network.Socket.SendFile+import System.IO++-- TODO: closing of file after getting filesize?++hSendFileResource :: (MonadIO m, HttpM Response m, SendM m, SocketQueueM m) => FilePath -> m ()+hSendFileResource f =+  hSafeIO (openBinaryFile f ReadMode) $ \fd ->+  hSafeIO (hFileSize fd)              $ \fs ->+    do response $+         do status        =: OK+            contentType   =: Just (fileMime f, Just "utf-8")+            contentLength =: Just fs+       enqueueSock (\s -> sendFile' s f 0 fs)+
+ src/Network/Salvia/Handler/StringTemplate.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleContexts #-}+module Network.Salvia.Handler.StringTemplate where++import Control.Monad.Trans+import Network.Protocol.Http+import Network.Salvia+import Text.StringTemplate++hStringTemplate+  :: (ToSElem a, MonadIO m, HttpM Response m, SendM m)+  => FilePath -> [(String, a)] -> m ()+hStringTemplate template attrs =+  hFileResourceFilter (render . setManyAttrib attrs . newSTMP) template+
+ src/Network/Salvia/Impl/C10k.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Network.Salvia.Impl.C10k where++import Data.Monoid+import Control.Monad.State+import Control.Applicative+import Network.C10kServer+import Network.Protocol.Http hiding (accept, hostname)+import Network.Salvia.Impl.Context +import Network.Salvia.Interface+import Network.Salvia.Impl.Handler+import Network.Socket+import System.IO++newtype C10kHandler p a = C10kHandler (Handler p a)+  deriving+  ( BodyM Request +  , Alternative +  , Applicative +  , BodyM Response +  , ClientAddressM +  , FlushM Request +  , FlushM Response +  , ForkM IO+  , Functor +  , HandleM +  , HttpM Request +  , HttpM Response +  , Monad+  , MonadIO +  , MonadPlus +  , Monoid+  , QueueM +  , RawHttpM Request +  , RawHttpM Response +  , SendM +  , ServerAddressM +  , ServerM +  , SocketM +  )++runC10kHandler :: C10kHandler p a -> Context p -> IO (a, Context p)+runC10kHandler (C10kHandler h) = runHandler h++start :: String -> String -> C10kConfig -> C10kHandler p () -> p -> IO ()+start hst admn conf handler pyld =+   do putStrLn ("Starting listening server on: 0.0.0.0:" ++ portName conf)+      flip runC10kServer conf $ \s ->+        do p <- getPeerName s+           n <- getSocketName s+           h <- socketToHandle s ReadWriteMode+           _ <- runC10kHandler handler+             Context+             { _cServerHost  = hst+             , _cAdminMail   = admn+             , _cListenOn    = [n]+             , _cPayload     = pyld+             , _cRequest     = emptyRequest+             , _cResponse    = emptyResponse+             , _cRawRequest  = emptyRequest+             , _cRawResponse = emptyResponse+             , _cSocket      = s+             , _cHandle      = h+             , _cClientAddr  = p+             , _cServerAddr  = n+             , _cQueue       = []+             }+           return ()+
+ src/Network/Salvia/Impl/Cgi.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}+module Network.Salvia.Impl.Cgi+( CgiHandler (..)+, hCgiEnv+, runCgiHandler+, start+)+where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Record.Label+import Network.Protocol.Http hiding (accept, hostname)+import Network.Salvia.Handlers+import Network.Salvia.Impl.Context +import Network.Salvia.Impl.Handler+import Network.Salvia.Interface+import Network.Socket+import System.Environment+import System.IO++newtype CgiHandler p a = CgiHandler (Handler p a)+  deriving+  ( BodyM Request +  , Alternative +  , Applicative +  , ClientAddressM +  , FlushM Request +  , FlushM Response +  , Functor +  , HandleM+  , HttpM Request +  , HttpM Response +  , Monad+  , MonadIO +  , MonadPlus +  , Monoid+  , HandleQueueM +  , QueueM +  , RawHttpM Request +  , RawHttpM Response +  , SendM +  , ForkM IO+  , ServerAddressM +  , ServerM +  )++hCgiEnv :: (FlushM Response m, MonadIO m, QueueM m, HttpM' m, HandleM m) => m a -> m ()+hCgiEnv handler =+  do hBanner "salvia-httpd"+     _ <- hHead handler+     h <- handle+     st <- response (getM status)+     liftIO $ hPutStr h (intercalate " " ["Status:", show (codeFromStatus st), show st] ++ "\r\n")+     hFlushHeadersOnly forResponse+     flushQueue forResponse++runCgiHandler :: CgiHandler p a -> Context p -> IO (a, Context p)+runCgiHandler (CgiHandler h) = runHandler h++start :: Show p => String -> CgiHandler p () -> p -> IO ()+start prefix handler pyld =+  do env <- getEnvironment++     -- Setup HTTP request from environment variables.+     let ur   = fromMaybe ""                   (lookup "REQUEST_URI"     env)+         qy   = maybe "" ('?':)                (lookup "QUERY_STRING"    env)+         mthd = maybe GET methodFromString     (lookup "REQUEST_METHOD"  env)+         prot = maybe http11 versionFromString (lookup "SERVER_PROTOCOL" env)+         req  = Http (Request mthd (fromMaybe ur (stripPrefix prefix ur) ++ qy)) prot (getHeaders env)++     -- Both the server and client address/port combinations.+     sa <- getAddrInfo Nothing (lookup "SERVER_ADDR" env) (lookup "SERVER_PORT" env)+     ca <- getAddrInfo Nothing (lookup "REMOTE_ADDR" env) (lookup "REMOTE_PORT" env)++     -- Run the handler with the context from the CGI environment.+     _ <- runCgiHandler handler+       Context+       { _cServerHost  = fromMaybe "" (lookup "SERVER_NAME"  env)+       , _cAdminMail   = fromMaybe "" (lookup "SERVER_ADMIN" env)+       , _cListenOn    = map addrAddress sa+       , _cPayload     = pyld+       , _cRequest     = req+       , _cResponse    = emptyResponse+       , _cRawRequest  = req+       , _cRawResponse = emptyResponse+       , _cSocket      = error "No socket available in CGI mode."+       , _cHandle      = stdout+       , _cClientAddr  = addrAddress (head ca)+       , _cServerAddr  = addrAddress (head sa)+       , _cQueue       = []+       }+     return ()++getHeaders :: [(String, String)] -> Headers+getHeaders =+    Headers+  . map (\(a, b) -> (norm a, b))+  . filter (("HTTP_" `isPrefixOf`) . fst)+  where norm = normalizeHeader . replace '_' '-' . fromJust . stripPrefix "HTTP_"++replace :: Eq a => a -> a -> [a] -> [a]+replace x y = map (\z -> if z == x then y else z)+
+ src/Util/Terminal.hs view
@@ -0,0 +1,211 @@+module Util.Terminal+( esc++, clearAll+, clearEol+, clear   ++, move+, moveUp     +, moveDown   +, moveBack   +, moveForward++, save+, load++, clr+, fg+, bg++, normal   +, bold     +, faint    +, standout +, underline+, blink    +, inverse  +, invisible++, Color (..)++, reset+, black  +, red    +, green  +, yellow +, blue   +, magenta+, cyan   +, white  ++, blackBold  +, redBold    +, greenBold  +, yellowBold +, blueBold   +, magentaBold+, cyanBold   +, whiteBold  ++, blackBg  +, redBg    +, greenBg  +, yellowBg +, blueBg   +, magentaBg+, cyanBg   +, whiteBg  +, resetBg  ++, width+, height+, geometry+)+where++import Control.Applicative+import Data.List (intercalate)+import System.Environment (getEnvironment)++-- Ansi escape sequence generation.++-- Generic function for producing ANSI escape sequences.+esc :: String -> [String] -> String -> String+esc a args b = concat ["\ESC[", a, intercalate ";" $ args, b]++-- Clear screen and end-of-line+clearAll, clearEol, clear :: String+clearAll = esc "2J" [] ""+clearEol = esc "K"  [] "" +clear    = clearAll ++ move 1 1++-- Move the cursor to the specified row and column.+move :: Int -> Int -> String+move row col = esc "" [show col, show row] "H"++-- Relative cursor movements.+moveUp, moveDown, moveBack, moveForward :: Int -> String++moveUp      rs = esc "" [show rs] "A"+moveDown    rs = esc "" [show rs] "B"+moveBack    cs = esc "" [show cs] "D"+moveForward cs = esc "" [show cs] "C"++-- Load and store the current cursor position.+save :: String+save = esc "s" [] ""++load :: String+load = esc "u" [] ""++-- Generic function for creating (foreground) color sequences.+clr :: [String] -> String+clr codes = esc "" codes "m"++-- Create foreground and background colors.+fg :: Color -> [String]+fg c = [show ((num c :: Int) + 30)]++bg :: Color -> [String]+bg c = [show ((num c :: Int) + 40)]++-- Style modifiers.+normal, bold, faint, standout, underline, blink, inverse, invisible+  :: [String] -> [String]++normal    = ("0":)+bold      = ("1":)+faint     = ("2":)+standout  = ("3":)+underline = ("4":)+blink     = ("5":)+inverse   = ("7":)+invisible = ("8":)++-- Ansi color listing.++data Color =+    Black+  | Red+  | Green+  | Yellow+  | Blue+  | Magenta+  | Cyan+  | White+  | Reset+  deriving (Show, Eq)++-- Ansi codes offsets for color values.+num :: Num a => Color -> a+num Black   = 0+num Red     = 1+num Green   = 2+num Yellow  = 3+num Blue    = 4+num Magenta = 5+num Cyan    = 6+num White   = 7+num Reset   = 9++-- Shortcut functions for common actions.++-- Reset all color and style information.+reset :: String+reset = esc "" ["0", "39", "49"] "m"++-- Shortcut for setting foreground colors.+black, red, green, yellow, blue,+  magenta, cyan, white :: String++black   = clr $ fg Black+red     = clr $ fg Red+green   = clr $ fg Green+yellow  = clr $ fg Yellow+blue    = clr $ fg Blue+magenta = clr $ fg Magenta+cyan    = clr $ fg Cyan+white   = clr $ fg White++-- Shortcut for setting bold foreground colors.+blackBold, redBold, greenBold, yellowBold, blueBold,+  magentaBold, cyanBold, whiteBold :: String++blackBold   = clr $ bold $ fg Black+redBold     = clr $ bold $ fg Red+greenBold   = clr $ bold $ fg Green+yellowBold  = clr $ bold $ fg Yellow+blueBold    = clr $ bold $ fg Blue+magentaBold = clr $ bold $ fg Magenta+cyanBold    = clr $ bold $ fg Cyan+whiteBold   = clr $ bold $ fg White++-- Shortcut for setting background colors.+blackBg, redBg, greenBg, yellowBg, blueBg,+  magentaBg, cyanBg, whiteBg, resetBg :: String++blackBg   = clr $ bg Black+redBg     = clr $ bg Red+greenBg   = clr $ bg Green+yellowBg  = clr $ bg Yellow+blueBg    = clr $ bg Blue+magentaBg = clr $ bg Magenta+cyanBg    = clr $ bg Cyan+whiteBg   = clr $ bg White+resetBg   = clr $ bg Reset++-- Terminal geometry.++-- Try to read terminal width from environment variable.+width :: IO Int+width = (maybe 80 read . lookup "COLUMNS") <$> getEnvironment++-- Try to read terminal height from environment variable.+height :: IO Int+height = (maybe 24 read . lookup "LINES") <$> getEnvironment++-- Try to read terminal width and height from environment variables.+geometry :: IO (Int, Int)+geometry = (,) <$> width <*> height+