diff --git a/salvia.cabal b/salvia.cabal --- a/salvia.cabal +++ b/salvia.cabal @@ -1,85 +1,98 @@ -Name: salvia -Version: 0.1.2 -Description: Lightweight Haskell Web Server Framework with modular support - for serving static files, directories indices, default error - responses, connection counting and logging, HEAD and PUT - requests, keep-alives, custom banner printing, default - handler environments for parsing request and printing - responses, dispatching based on request methods, URI, paths - and filename extension, URI rewriting and redirection, - virtual hosting, cookie, session and user management and - more... +Name: salvia +Version: 1.0.0 +Description: + Salvia is a feature rich modular web server and web application framework + that can be used to write dynamic websites in Haskell. From the lower level + protocol code up to the high level application code, everything is written as + a Salvia handler. This approach makes the server extremely extensible. To see + a demo of a Salvia website, please see the /salvia-demo/ package. + . + All the low level protocol code can be found in the /salvia-protocol/ + package, which exposes the datatypes, parsers and pretty-printers for the + URI, HTTP, Cookie and MIME protocols. + . + This Salvia package itself can be separated into three different parts: the + interface, the handlers and the implementation. The /interface/ module + defines a number of type classes that the user can build the web application + against. Reading the request object, writing to the response, or gaining + direct access to the socket, all of these actions are reflected using one + type class aspect in the interface. The /handlers/ are self contained modules + that implement a single aspect of the Salvia web server. The handlers expose + their interface requirements in their type context. Salvia can have multiple + /implementations/ which can be switched by using different instances for the + interface type classes. This package has only one implementation, a simple + accepting socket loop server. The /salvia-extras/ package has two additional + implementations. Keeping a clear distinction between the abstract server + aspects and the actual implementation makes it very easy to migrate existing + web application to different back-ends. -Synopsis: Lightweight Haskell Web Server Framework -Cabal-version: >= 1.6 -Category: Network, Web -License: BSD3 -License-file: LICENSE -Author: Sebastiaan Visser -Maintainer: sfvisser@cs.uu.nl -Build-Type: Simple -Build-Depends: base ==3.0.*, - network ==2.2.*, - containers ==0.2.*, - parsec ==3.0.*, - filepath == 1.1.*, - fclabels ==0.1.*, - utf8-string ==0.3.*, - bytestring ==0.9.*, - old-locale ==1.0.*, - time ==1.1.*, - encoding ==0.5.*, - process ==1.0.*, - stm ==2.1.*, - pureMD5 ==0.2.*, - directory ==1.0.*, - bimap ==0.2.*, - mtl ==1.1.*, - random ==1.0.* -GHC-Options: -threaded -Wall -fno-warn-orphans -Extensions: CPP -HS-Source-Dirs: src -Other-modules: Misc.Misc, - Misc.Terminal, - Network.Protocol.Http.Data, - Network.Protocol.Http.Parser, - Network.Protocol.Http.Printer, - Network.Protocol.Http.Status -Exposed-modules: Demo, - Network.Protocol.Cookie, - Network.Protocol.Http, - Network.Protocol.Mime, - Network.Protocol.Uri, - Network.Salvia.Core.Config, - Network.Salvia.Core.Context, - Network.Salvia.Core.Handler, - Network.Salvia.Core.IO, - Network.Salvia.Core.Main, - Network.Salvia.Handler.Banner, - Network.Salvia.Handler.CGI, - Network.Salvia.Handler.Close, - Network.Salvia.Handler.Cookie, - Network.Salvia.Handler.Counter, - Network.Salvia.Handler.Directory, - Network.Salvia.Handler.Dispatching, - Network.Salvia.Handler.Environment, - Network.Salvia.Handler.Error, - Network.Salvia.Handler.ExtensionDispatcher, - Network.Salvia.Handler.Fallback, - Network.Salvia.Handler.File, - Network.Salvia.Handler.FileSystem, - Network.Salvia.Handler.Head, - Network.Salvia.Handler.Log, - Network.Salvia.Handler.Login, - Network.Salvia.Handler.MethodRouter, - Network.Salvia.Handler.Parser, - Network.Salvia.Handler.PathRouter, - Network.Salvia.Handler.Printer, - Network.Salvia.Handler.Put, - Network.Salvia.Handler.Redirect, - Network.Salvia.Handler.Rewrite, - Network.Salvia.Handler.Session, - Network.Salvia.Handler.VirtualHosting, - Network.Salvia.Handlers - Network.Salvia.Httpd +Synopsis: Modular web application framework. +Cabal-version: >= 1.6 +Category: Network, Web +License: BSD3 +License-file: LICENSE +Author: Sebastiaan Visser +Maintainer: sfvisser@cs.uu.nl +Build-Type: Simple + +Library + GHC-Options: -Wall -fno-warn-orphans + HS-Source-Dirs: src + + Build-Depends: base ==4.*, + bytestring ==0.9.*, + containers >= 0.2 && < 0.4, + directory ==1.0.*, + fclabels ==0.4.*, + MaybeT-transformers == 0.1.*, + monads-fd ==0.0.*, + network >= 2.2.1.7 && < 2.3, + old-locale ==1.0.*, + process ==1.0.*, + threadmanager ==0.1.3, + pureMD5 ==1.0.*, + random ==1.0.*, + safe ==0.2.*, + stm ==2.1.*, + time ==1.1.*, + transformers ==0.1.*, + unix >= 2.3 && < 2.5, + utf8-string ==0.3.*, + salvia-protocol ==1.0.*, + split ==0.1.*, + text >= 0.5 && < 0.8 + + Exposed-modules: Network.Salvia + Network.Salvia.Interface + Network.Salvia.Handlers + Network.Salvia.Impl + + Network.Salvia.Impl.Config + Network.Salvia.Impl.Context + Network.Salvia.Impl.Handler + Network.Salvia.Impl.Server + + Network.Salvia.Handler.Banner + Network.Salvia.Handler.Body + Network.Salvia.Handler.CGI + Network.Salvia.Handler.Close + Network.Salvia.Handler.Cookie + Network.Salvia.Handler.Directory + Network.Salvia.Handler.Dispatching + Network.Salvia.Handler.Environment + Network.Salvia.Handler.Error + Network.Salvia.Handler.Extension + Network.Salvia.Handler.File + Network.Salvia.Handler.FileSystem + Network.Salvia.Handler.Head + Network.Salvia.Handler.Log + Network.Salvia.Handler.Method + Network.Salvia.Handler.Parser + Network.Salvia.Handler.Path + Network.Salvia.Handler.Printer + Network.Salvia.Handler.Put + Network.Salvia.Handler.Range + Network.Salvia.Handler.Redirect + Network.Salvia.Handler.Rewrite + Network.Salvia.Handler.VirtualHosting diff --git a/src/Demo.hs b/src/Demo.hs deleted file mode 100644 --- a/src/Demo.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Demo where - -import Network.Socket -import Network.Salvia.Httpd -import Network.Salvia.Handlers - --- Serve the current directory. - -main :: IO () -main = do - conf <- defaultConfig - addr <- inet_addr "127.0.0.1" - start - (conf { listenAddr = addr, listenPort = 8080 }) - (hDefaultEnv myHandler) - --- Serve the current directory. - -myHandler :: Handler () -myHandler = hFileSystem "." - diff --git a/src/Misc/Misc.hs b/src/Misc/Misc.hs deleted file mode 100644 --- a/src/Misc/Misc.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} - -module Misc.Misc ( - eitherToMaybe - , bool - , pMaybe - , (@@) - , safeLast - , guardMaybe - , ifM - , split - , withReverse - , intersperseS - , trim - , normalCase - , safeRead - , now - , later - , safeHead - , atomModTVar - , atomReadTVar - , atomWithTVar - ) where - -import Control.Applicative -import Control.Concurrent.STM -import Control.Monad -import Data.Char -import Data.Time.Clock -import Data.Time.LocalTime -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) - --------[ common utilities ]---------------------------------------------------- - -bool :: a -> a -> Bool -> a -bool a b c = if c then a else b - -safeRead :: Read a => String -> Maybe a -safeRead s = case reads s of - [(x, "")] -> Just x - _ -> Nothing - --- Conversions. - -guardMaybe :: Bool -> Maybe () -guardMaybe = bool (Just ()) Nothing - -eitherToMaybe :: Either a b -> Maybe b -eitherToMaybe = either (const Nothing) Just - --------[ list utilities ]------------------------------------------------------ - -safeList :: ([a] -> b) -> [a] -> Maybe b -safeList _ [] = Nothing -safeList f xs = Just $ f xs - -safeHead :: [a] -> Maybe a -safeHead = safeList head - -safeLast :: [a] -> Maybe a -safeLast = safeList last - -withReverse :: ([a] -> [b]) -> [a] -> [b] -withReverse f = reverse . f . reverse - -trimWith :: (a -> Bool) -> [a] -> [a] -trimWith f = withReverse (dropWhile f) . dropWhile f - -split :: Eq a => a -> [a] -> [[a]] -split c = splitWith (==c) - -splitWith :: (a -> Bool) -> [a] -> [[a]] -splitWith f xs = - case span (not . f) (dropWhile f xs) of - ([], []) -> [] - (a, []) -> [a] - (a, b) -> a : splitWith f b - --------[ text manipulation ]--------------------------------------------------- - -normalCase :: String -> String -normalCase "" = "" -normalCase (x:xs) = toUpper x : map toLower xs - --- Trim all heading and trailing whitespace. -trim :: String -> String -trim = trimWith (`elem` " \t\n\r") - --- ShowS functions. - -intersperseS :: ShowS -> [ShowS] -> ShowS -intersperseS _ [] = id -intersperseS _ [s] = s -intersperseS c xs = foldl1 (\a -> ((a.c).)) xs - --------[ second arity functor ]------------------------------------------------ - -class Functor2 f where - fmap2 :: (a -> c) -> (b -> d) -> f a b -> f c d - -instance Functor2 (,) where - fmap2 f g (a, b) = (f a, g b) - -instance Functor2 Either where - fmap2 f _ (Left a) = Left (f a) - fmap2 _ g (Right b) = Right (g b) - --------[ monadic expressions ]------------------------------------------------- - -ifM :: Monad m => m Bool -> (a -> a) -> a -> m a -ifM t f g = t >>= (\b -> return $ if b then f g else g) - --------[ parsec extensions ]--------------------------------------------------- - --- Helper function to quickly apply a parser. -(@@) :: GenParser Char () a -> String -> Maybe a -(@@) p b = either (const Nothing) Just $ parse (p <* eof) "" b - --- Option parser with maybe result. -pMaybe :: GenParser a b c -> GenParser a b (Maybe c) -pMaybe = option Nothing . liftM Just - --- Make parsec both applicative and alternative. -{-instance Applicative (GenParser s a) where - pure = return - (<*>) = ap - -instance Alternative (GenParser s a) where - empty = mzero - (<|>) = mplus-} - --------[ time utils ]---------------------------------------------------------- - -later :: Integer -> IO LocalTime -later howlong = do - zone <- getCurrentTimeZone - time <- liftM (addUTCTime $ fromInteger howlong) getCurrentTime - return $ utcToLocalTime zone time - -now :: IO LocalTime -now = later 0 - --------[ concurrency utils ]--------------------------------------------------- - -atomModTVar :: (a -> a) -> TVar a -> IO a -atomModTVar f v = atomically $ do - t <- readTVar v - writeTVar v (f t) - return (f t) - -atomReadTVar :: TVar a -> IO a -atomReadTVar = atomically . readTVar - -atomWithTVar :: (a -> b) -> TVar a -> IO b -atomWithTVar f v = atomically - $ liftM f (readTVar v) - diff --git a/src/Misc/Terminal.hs b/src/Misc/Terminal.hs deleted file mode 100644 --- a/src/Misc/Terminal.hs +++ /dev/null @@ -1,211 +0,0 @@ -module Misc.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 - diff --git a/src/Network/Protocol/Cookie.hs b/src/Network/Protocol/Cookie.hs deleted file mode 100644 --- a/src/Network/Protocol/Cookie.hs +++ /dev/null @@ -1,176 +0,0 @@ -{- | -For more information: http://www.ietf.org/rfc/rfc2109.txt --} - -module Network.Protocol.Cookie ( - Cookie (..) - , empty - - , Cookies - , cookies - , cookie - , showCookies - - , parseCookies - ) where - -import Control.Applicative hiding (empty) -import Control.Monad () -import Data.Char (toLower) -import Data.List (intercalate) -import Misc.Misc (intersperseS, (@@), trim) -import Network.Protocol.Uri (URI) -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) -import qualified Data.Map as M - - -{- | -The `Cookie` data type containg one key/value pair with all the (potentially -optional) meta-data. --} - -data Cookie = - Cookie { - name :: String - , value :: String - , comment :: Maybe String - , commentURL :: Maybe URI - , discard :: Bool - , domain :: Maybe String - , maxAge :: Maybe Int - , expires :: Maybe String - , path :: Maybe String - , port :: [Int] - , secure :: Bool - , version :: Int - } - -{- | Create an empty cookie. -} - -empty :: Cookie -empty = Cookie { - name = "" - , value = "" - , comment = Nothing - , commentURL = Nothing - , discard = False - , domain = Nothing - , maxAge = Nothing - , expires = Nothing - , path = Nothing - , port = [] - , secure = False - , version = 0 - } - -{- | -A collection of multiple cookies. These can all be set in one single HTTP -/Set-Cookie/ header field. --} - -type Cookies = M.Map String Cookie - -{- | -Convert a list of cookies into a cookie mapping. The name will be used as the -key, the cookie itself as the value. --} - -cookies :: [Cookie] -> Cookies -cookies = M.fromList . map (\a -> (name a, a)) - -{- | Case-insensitive way of getting a cookie out of a collection by name. -} - -cookie :: String -> Cookies -> Maybe Cookie -cookie n = M.lookup (map toLower n) - --------[ cookie show instance ]------------------------------------------------ - -instance Show Cookie where - show = flip showsCookie "" - --- Show a semicolon separated list of attribute/value pairs. Only meta pairs --- with significant values will be pretty printed. -showsCookie :: Cookie -> ShowS -showsCookie c = - pair (name c) (value c) - . opt "comment" (comment c) - . opt "commentURL" (fmap show $ commentURL c) - . bool "discard" (discard c) - . opt "domain" (domain c) - . opt "maxAge" (fmap show $ maxAge c) - . opt "expires" (expires c) - . opt "path" (path c) - . list "port" (map show $ port c) - . bool "secure" (secure c) - . opt "version" (optval $ version c) - where - attr a = showString a - val v = showString ("=" ++ v) - end = showString "; " - single a = attr a . end - pair a v = attr a . val v . end - opt a = maybe id (pair a) - list _ [] = id - list a xs = pair a $ intercalate "," xs - bool _ False = id - bool a True = single a - optval 0 = Nothing - optval i = Just (show i) - -{- | Show multiple cookies, pretty printed using a comma separator. -} - -showCookies :: Cookies -> String -showCookies = ($"") - . intersperseS (showString ", ") - . map (shows . snd) - . M.toList - --------[ cookie parser ]------------------------------------------------------- - -{- | -Parse a set of cookie values and turn this into a collection of real cookies. -As the specification states, only the name, value, domain, path and port will -be recognized. --} - -parseCookies :: String -> Maybe Cookies -parseCookies = fmap cookies . (pCookie @@) - -pCookie :: GenParser Char st [Cookie] -pCookie = map ck <$> pCookieValues - where - ck ((n, v), m) = - empty { - name = n - , value = v - , domain = "$domain" `M.lookup` m - , path = "$path" `M.lookup` m - , port = maybe [] pPorts $ - "$port" `M.lookup` m - } - --- Parse a list of comma separated portnumbers. Returns a list of integers or --- an empty list on failure. -pPorts :: String -> [Int] -pPorts = either (const []) id . parse p "" - where - p = char '"' - *> sepBy1 (read <$> many1 digit) (char ',') - <* char '"' - --- Parse a collection of cookie name/value pairs. -pCookieValues :: GenParser Char st [((String, String), M.Map String String)] -pCookieValues = - flip sepBy1 sep ((,) - <$> pair key - <*> (M.fromList - <$> filter (not . null . fst) - <$> many (try (sep *> pair skey)))) - where - f = trim . map toLower - key = f <$> many1 (noneOf "=;") - skey = f <$> ((:) <$> char '$' <*> many (noneOf "=;")) - val = trim <$> many (noneOf ";") - pair k = (,) <$> k <*> (char '=' *> val) - sep = char ';' *> many (oneOf " \t\r\n") - diff --git a/src/Network/Protocol/Http.hs b/src/Network/Protocol/Http.hs deleted file mode 100644 --- a/src/Network/Protocol/Http.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Network.Protocol.Http( - - -- * HTTP message data types. - - Method (..) - , methods - , Version (Version) - , HeaderKey - , HeaderValue - , Headers - , Direction (Request, Response) - , Message (Message) - - -- * Creating (parts of) messages. - - , emptyRequest - , emptyResponse - , http10 - , http11 - - -- * Accessing fields. - - , major - , minor - , body - , headers - , version - , direction - , method - , uri - , status - - -- * Accessing specific header fields. - - , normalizeHeader - , header - - , utf8 - - , connection - , contentLength - , contentType - , cookie - , date - , hostname - , keepAlive - , location - , server - - -- * Parsing HTTP messages. - - , parseRequest - , parseResponse - - -- * Printing HTTP messages. - - , showMessageHeader - - -- * Handling HTTP status codes. - - , Status (..) - , statusCodes - , statusFailure - , statusFromCode - , codeFromStatus - - ) where - -import Network.Protocol.Http.Data -import Network.Protocol.Http.Parser -import Network.Protocol.Http.Printer -import Network.Protocol.Http.Status - diff --git a/src/Network/Protocol/Http/Data.hs b/src/Network/Protocol/Http/Data.hs deleted file mode 100644 --- a/src/Network/Protocol/Http/Data.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Network.Protocol.Http.Data where - -import Data.List (intercalate) -import Data.Map (lookup, insert, Map, empty) -import Data.Record.Label -import Misc.Misc (safeRead, normalCase, split) -import Network.Protocol.Http.Status (Status (..)) -import Network.Protocol.Uri -import Prelude hiding (lookup) - -{- | List of HTTP request methods. -} - -data Method = - OPTIONS - | GET - | HEAD - | POST - | PUT - | DELETE - | TRACE - | CONNECT - deriving (Show, Eq) - -{- | All `Method` constructors as a list. -} - -methods :: [Method] -methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT] - -{- | HTTP protocol version. -} - -data Version = Version {_major :: Int, _minor :: Int} - -{- | Create HTTP 1.0 version. -} - -http10 :: Version -http10 = Version 1 0 - -{- | Create HTTP 1.1 version. -} - -http11 :: Version -http11 = Version 1 1 - -type HeaderKey = String -type HeaderValue = String - -{- | HTTP headers as mapping from keys to values. -} - -type Headers = Map HeaderKey HeaderValue - -{- | Request or response specific part of HTTP messages. -} - -data Direction = - Request {__method :: Method, __uri :: URI} - | Response {__status :: Status} - -{- | An HTTP message. -} - -data Message = - Message { - _direction :: Direction - , _version :: Version - , _headers :: Headers - , _body :: String - } - -{- | Create an empty HTTP request object. -} - -emptyRequest :: Message -emptyRequest = Message (Request GET (mkURI)) http11 empty "" - -{- | Create an empty HTTP response object. -} - -emptyResponse :: Message -emptyResponse = Message (Response OK) http11 empty "" - -$(mkLabels [''Version, ''Direction, ''Message]) - -{- | Label to access the major part of the version. -} - -major :: Label Version Int - -{- | Label to access the minor part of the version. -} - -minor :: Label Version Int - -_status :: Label Direction Status -_uri :: Label Direction URI -_method :: Label Direction Method - -{- | Label to access the body part of an HTTP message. -} - -body :: Label Message String - -{- | Label to access the header of an HTTP message. -} - -headers :: Label Message Headers - -{- | Label to access the version part of an HTTP message. -} - -version :: Label Message Version - -{- | Label to access the direction part of an HTTP message. -} - -direction :: Label Message Direction - -{- | Label to access the method part of an HTTP message. -} - -method :: Label Message Method -method = _method % direction - -{- | Label to access the URI part of an HTTP message. -} - -uri :: Label Message URI -uri = _uri % direction - -{- | Label to access the status part of an HTTP message. -} - -status :: Label Message Status -status = _status % direction - - - - - -{- | Normalize the capitalization of an HTTP header key. -} - -normalizeHeader :: String -> String -normalizeHeader = (intercalate "-") . (map normalCase) . (split '-') - -{- | Generic label to access an HTTP header field by key. -} - -header :: HeaderKey -> Label Message HeaderValue -header key = - Label { - lget = maybe "" id . lookup (normalizeHeader key) . lget headers - , lset = lmod headers . insert (normalizeHeader key) - } - -{- | Simply /utf-8/. -} - -utf8 :: String -utf8 = "utf-8" - -{- | Access the /Content-Length/ header field. -} - -contentLength :: (Read i, Integral i) => Label Message (Maybe i) -contentLength = comp safeRead (maybe "" show) (header "Content-Length") - -{- | Access the /Connection/ header field. -} - -connection :: Label Message String -connection = header "Connection" - -{- | Access the /Keep-Alive/ header field. -} - -keepAlive :: (Read i, Integral i) => Label Message (Maybe i) -keepAlive = comp safeRead (maybe "" show) (header "Keep-Alive") - -{- | Access the /Cookie/ and /Set-Cookie/ header fields. -} - -cookie :: Label Message String -cookie = Label (lget $ header "Cookie") (lset $ header "Set-Cookie") - -{- | Access the /Location/ header field. -} - -location :: Label Message (Maybe URI) -location = Label - (parseURI . lget (header "Location")) - (lset (header "Location") . maybe "" show) - -{- | Access the /Content-Type/ header field. -} - -contentType :: Label Message (String, Maybe String) -contentType = comp pa pr (header "Content-Type") - where pr (t, c) = t ++ maybe "" ("; charset="++) c - pa = error "no getter for contentType yet" - -{- | Access the /Data/ header field. -} - -date :: Label Message String -date = header "Date" - -{- | Access the /Host/ header field. -} - -hostname :: Label Message (Maybe Authority) -hostname = Label - (parseAuthority . lget (header "Host")) - (lset (header "Host") . maybe "" show) - -{- | Access the /Server/ header field. -} - -server :: Label Message String -server = header "Server" - diff --git a/src/Network/Protocol/Http/Parser.hs b/src/Network/Protocol/Http/Parser.hs deleted file mode 100644 --- a/src/Network/Protocol/Http/Parser.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Network.Protocol.Http.Parser ( - parseRequest - , parseResponse - ) where - -import Control.Applicative hiding (empty) -import Data.Char (ord) -import Data.List (intercalate) -import Data.Map (insert, empty) -import Misc.Misc (pMaybe) -import Network.Protocol.Http.Data -import Network.Protocol.Http.Status -import Network.Protocol.Uri (pUriReference) -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) - -{- | Parse a string as an HTTP request message. -} - -parseRequest :: String -> Either ParseError Message -parseRequest msg = parse pRequest "" msg - -{- | Parse a string as an HTTP request message. -} - -parseResponse :: String -> Either ParseError Message -parseResponse msg = parse pResponse "" msg - -lf, ws, ls :: String -lf = "\r\n" -ws = " \t\r\n" -ls = " \t" - -pLf :: GenParser Char st Char -pLf = (char '\r' <* pMaybe (char '\n')) <|> char '\n' - -pVersion :: GenParser Char st Version -pVersion = - (\h l -> Version (ord h - ord '0') (ord l - ord '0')) - <$> (string "HTTP/" *> digit) - <*> (char '.' *> digit) - -pHeaders :: GenParser Char st Headers -pHeaders = insert - <$> many1 (noneOf (':':ws)) <* string ":" - <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* pLf)) - <*> option empty pHeaders - -pMethod :: GenParser Char st Method -pMethod = choice $ map (\a -> a <$ (try $ string $ show a)) methods - -pRequest :: GenParser Char st Message -pRequest = (\m u v h b -> Message (Request m u) v h b) - <$> (pMethod <* many1 (oneOf ls)) - <*> (pUriReference <* many1 (oneOf ls)) - <*> (pVersion <* pLf) - <*> (pHeaders <* pLf) - <*> (many anyToken) - -pResponse :: GenParser Char st Message -pResponse = (\v s h b -> Message (Response (statusFromCode $ read s)) v h b) - <$> (pVersion <* many1 (oneOf ls)) - <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* pLf) - <*> (pHeaders <* pLf) - <*> (many anyToken) - diff --git a/src/Network/Protocol/Http/Printer.hs b/src/Network/Protocol/Http/Printer.hs deleted file mode 100644 --- a/src/Network/Protocol/Http/Printer.hs +++ /dev/null @@ -1,41 +0,0 @@ -{- | Provides the `Show` instance for an HTTP `Message`. -} - -module Network.Protocol.Http.Printer (showMessageHeader) where - -import Data.Bimap (lookupR) -import Data.List (intercalate) -import Data.Map (elems, mapWithKey) -import Data.Record.Label (lget) -import Network.Protocol.Http.Data -import Network.Protocol.Http.Status - -lf :: String -lf = "\r\n" - -instance Show Version where - show (Version a b) = concat ["HTTP/", show a, ".", show b] - -showHeaders :: Headers -> String -showHeaders = - intercalate lf - . elems - . mapWithKey (\k a -> k ++ ": " ++ a) - -{- | Helper function that only prints the header part of an HTTP message. -} - -showMessageHeader :: Message -> String -showMessageHeader (Message (Response s) v hs _) = - concat [ - show v, " " - , maybe "Unknown status" show - $ lookupR s statusCodes, " " - , show s, lf - , showHeaders hs, lf, lf - ] - -showMessageHeader (Message (Request m u) v hs _) = - concat [show m, " ", show u, " ", show v, lf, showHeaders hs, lf, lf] - -instance Show Message where - show m = concat [showMessageHeader m, lget body m] - diff --git a/src/Network/Protocol/Http/Status.hs b/src/Network/Protocol/Http/Status.hs deleted file mode 100644 --- a/src/Network/Protocol/Http/Status.hs +++ /dev/null @@ -1,163 +0,0 @@ -module Network.Protocol.Http.Status where - -import Data.Bimap (Bimap, fromList, lookup, lookupR) -import Data.Maybe (fromMaybe) -import Prelude hiding (lookup) - -{- | HTTP status codes. -} - -data Status = - Continue -- ^ 100 - | SwitchingProtocols -- ^ 101 - | OK -- ^ 200 - | Created -- ^ 201 - | Accepted -- ^ 202 - | NonAuthoritativeInformation -- ^ 203 - | NoContent -- ^ 204 - | ResetContent -- ^ 205 - | PartialContent -- ^ 206 - | MultipleChoices -- ^ 300 - | MovedPermanently -- ^ 301 - | Found -- ^ 302 - | SeeOther -- ^ 303 - | NotModified -- ^ 304 - | UseProxy -- ^ 305 - | TemporaryRedirect -- ^ 307 - | BadRequest -- ^ 400 - | Unauthorized -- ^ 401 - | PaymentRequired -- ^ 402 - | Forbidden -- ^ 403 - | NotFound -- ^ 404 - | MethodNotAllowed -- ^ 405 - | NotAcceptable -- ^ 406 - | ProxyAuthenticationRequired -- ^ 407 - | RequestTimeOut -- ^ 408 - | Conflict -- ^ 409 - | Gone -- ^ 410 - | LengthRequired -- ^ 411 - | PreconditionFailed -- ^ 412 - | RequestEntityTooLarge -- ^ 413 - | RequestURITooLarge -- ^ 414 - | UnsupportedMediaType -- ^ 415 - | RequestedRangeNotSatisfiable -- ^ 416 - | ExpectationFailed -- ^ 417 - | InternalServerError -- ^ 500 - | NotImplemented -- ^ 501 - | BadGateway -- ^ 502 - | ServiceUnavailable -- ^ 503 - | GatewayTimeOut -- ^ 504 - | HTTPVersionNotSupported -- ^ 505 - | CustomStatus Int - deriving (Eq, Ord) - -{- | rfc2616 sec6.1.1 Status Code and Reason Phrase. -} - -instance Show Status where - show Continue = "Continue" - show SwitchingProtocols = "Switching Protocols" - show OK = "OK" - show Created = "Created" - show Accepted = "Accepted" - show NonAuthoritativeInformation = "Non-Authoritative Information" - show NoContent = "No Content" - show ResetContent = "Reset Content" - show PartialContent = "Partial Content" - show MultipleChoices = "Multiple Choices" - show MovedPermanently = "Moved Permanently" - show Found = "Found" - show SeeOther = "See Other" - show NotModified = "Not Modified" - show UseProxy = "Use Proxy" - show TemporaryRedirect = "Temporary Redirect" - show BadRequest = "Bad Request" - show Unauthorized = "Unauthorized" - show PaymentRequired = "Payment Required" - show Forbidden = "Forbidden" - show NotFound = "Not Found" - show MethodNotAllowed = "Method Not Allowed" - show NotAcceptable = "Not Acceptable" - show ProxyAuthenticationRequired = "Proxy Authentication Required" - show RequestTimeOut = "Request Time-out" - show Conflict = "Conflict" - show Gone = "Gone" - show LengthRequired = "Length Required" - show PreconditionFailed = "Precondition Failed" - show RequestEntityTooLarge = "Request Entity Too Large" - show RequestURITooLarge = "Request-URI Too Large" - show UnsupportedMediaType = "Unsupported Media Type" - show RequestedRangeNotSatisfiable = "Requested range not satisfiable" - show ExpectationFailed = "Expectation Failed" - show InternalServerError = "Internal Server Error" - show NotImplemented = "Not Implemented" - show BadGateway = "Bad Gateway" - show ServiceUnavailable = "Service Unavailable" - show GatewayTimeOut = "Gateway Time-out" - show HTTPVersionNotSupported = "HTTP Version not supported" - show (CustomStatus _) = "Unknown Status" - -{- | -RFC2616 sec6.1.1 Status Code and Reason Phrase. - -Bidirectional mapping from status numbers to codes. --} - -statusCodes :: Bimap Int Status -statusCodes = fromList [ - (100, Continue) - , (101, SwitchingProtocols) - , (200, OK) - , (201, Created) - , (202, Accepted) - , (203, NonAuthoritativeInformation) - , (204, NoContent) - , (205, ResetContent) - , (206, PartialContent) - , (300, MultipleChoices) - , (301, MovedPermanently) - , (302, Found) - , (303, SeeOther) - , (304, NotModified) - , (305, UseProxy) - , (307, TemporaryRedirect) - , (400, BadRequest) - , (401, Unauthorized) - , (402, PaymentRequired) - , (403, Forbidden) - , (404, NotFound) - , (405, MethodNotAllowed) - , (406, NotAcceptable) - , (407, ProxyAuthenticationRequired) - , (408, RequestTimeOut) - , (409, Conflict) - , (410, Gone) - , (411, LengthRequired) - , (412, PreconditionFailed) - , (413, RequestEntityTooLarge) - , (414, RequestURITooLarge) - , (415, UnsupportedMediaType) - , (416, RequestedRangeNotSatisfiable) - , (417, ExpectationFailed) - , (500, InternalServerError) - , (501, NotImplemented) - , (502, BadGateway) - , (503, ServiceUnavailable) - , (504, GatewayTimeOut) - , (505, HTTPVersionNotSupported) - ] - --- | Every status greater-than or equal to 400 is considered to be a failure. -statusFailure :: Status -> Bool -statusFailure st = codeFromStatus st >= 400 - --- | Conversion from status numbers to codes. -statusFromCode :: Int -> Status -statusFromCode num = - fromMaybe (CustomStatus num) - $ lookup num statusCodes - --- | Conversion from status codes to numbers. -codeFromStatus :: Status -> Int -codeFromStatus st = - fromMaybe 0 -- function is total, should not happen. - $ lookupR st statusCodes - diff --git a/src/Network/Protocol/Mime.hs b/src/Network/Protocol/Mime.hs deleted file mode 100644 --- a/src/Network/Protocol/Mime.hs +++ /dev/null @@ -1,662 +0,0 @@ -{- | -Handling mime types. This module contains a mapping from file extensions to -mime-types taken from the Apache webserver project. --} - -module Network.Protocol.Mime where - -import Data.Map - -{- | Get the mimetype for the specified extension. -} - -mime :: String -> Maybe String -mime ext = Data.Map.lookup ext extensionToMime - -{- | The default mimetype is /text/plain/. -} - -defaultMime :: String -defaultMime = "text/plain" - -{- | The mapping from extension to mimetype. -} - -extensionToMime :: Map String String -extensionToMime = fromList [ - ("123", "application/vnd.lotus-1-2-3") - , ("3dml", "text/vnd.in3d.3dml") - , ("3g2", "video/3gpp2") - , ("3gp", "video/3gpp") - , ("ace", "application/x-ace-compressed") - , ("acu", "application/vnd.acucobol") - , ("acutc", "application/vnd.acucorp") - , ("aep", "application/vnd.audiograph") - , ("afp", "application/vnd.ibm.modcap") - , ("ai", "application/postscript") - , ("aif", "audio/x-aiff") - , ("aifc", "audio/x-aiff") - , ("aiff", "audio/x-aiff") - , ("ami", "application/vnd.amiga.ami") - , ("apr", "application/vnd.lotus-approach") - , ("asc", "application/pgp-signature") - , ("asf", "application/vnd.ms-asf") - , ("asf", "video/x-ms-asf") - , ("asm", "text/x-asm") - , ("aso", "application/vnd.accpac.simply.aso") - , ("asx", "video/x-ms-asf") - , ("atc", "application/vnd.acucorp") - , ("atom", "application/atom+xml") - , ("atomcat", "application/atomcat+xml") - , ("atomsvc", "application/atomsvc+xml") - , ("atx", "application/vnd.antix.game-component") - , ("au", "audio/basic") - , ("bat", "application/x-msdownload") - , ("bcpio", "application/x-bcpio") - , ("bdm", "application/vnd.syncml.dm+wbxml") - , ("bh2", "application/vnd.fujitsu.oasysprs") - , ("bin", "application/octet-stream") - , ("bmi", "application/vnd.bmi") - , ("bmp", "image/bmp") - , ("box", "application/vnd.previewsystems.box") - , ("boz", "application/x-bzip2") - , ("bpk", "application/octet-stream") - , ("btif", "image/prs.btif") - , ("bz", "application/x-bzip") - , ("bz2", "application/x-bzip2") - , ("c", "text/x-c") - , ("c4d", "application/vnd.clonk.c4group") - , ("c4f", "application/vnd.clonk.c4group") - , ("c4g", "application/vnd.clonk.c4group") - , ("c4p", "application/vnd.clonk.c4group") - , ("c4u", "application/vnd.clonk.c4group") - , ("cab", "application/vnd.ms-cab-compressed") - , ("cc", "text/x-c") - , ("ccxml", "application/ccxml+xml") - , ("cdbcmsg", "application/vnd.contact.cmsg") - , ("cdf", "application/x-netcdf") - , ("cdkey", "application/vnd.mediastation.cdkey") - , ("cdx", "chemical/x-cdx") - , ("cdxml", "application/vnd.chemdraw+xml") - , ("cdy", "application/vnd.cinderella") - , ("cer", "application/pkix-cert") - , ("cgm", "image/cgm") - , ("chat", "application/x-chat") - , ("chm", "application/vnd.ms-htmlhelp") - , ("chrt", "application/vnd.kde.kchart") - , ("cif", "chemical/x-cif") - , ("cii", "application/vnd.anser-web-certificate-issue-initiation") - , ("cil", "application/vnd.ms-artgalry") - , ("cla", "application/vnd.claymore") - , ("class", "application/octet-stream") - , ("clkk", "application/vnd.crick.clicker.keyboard") - , ("clkp", "application/vnd.crick.clicker.palette") - , ("clkt", "application/vnd.crick.clicker.template") - , ("clkw", "application/vnd.crick.clicker.wordbank") - , ("clkx", "application/vnd.crick.clicker") - , ("clp", "application/x-msclip") - , ("cmc", "application/vnd.cosmocaller") - , ("cmdf", "chemical/x-cmdf") - , ("cml", "chemical/x-cml") - , ("cmp", "application/vnd.yellowriver-custom-menu") - , ("cmx", "image/x-cmx") - , ("com", "application/x-msdownload") - , ("conf", "text/plain") - , ("cpio", "application/x-cpio") - , ("cpp", "text/x-c") - , ("cpt", "application/mac-compactpro") - , ("crd", "application/x-mscardfile") - , ("crl", "application/pkix-crl") - , ("crt", "application/x-x509-ca-cert") - , ("csh", "application/x-csh") - , ("csml", "chemical/x-csml") - , ("csp", "application/vnd.commonspace") - , ("css", "text/css") - , ("cst", "application/vnd.commonspace") - , ("csv", "text/csv") - , ("curl", "application/vnd.curl") - , ("cww", "application/prs.cww") - , ("cxx", "text/x-c") - , ("daf", "application/vnd.mobius.daf") - , ("davmount", "application/davmount+xml") - , ("dcr", "application/x-director") - , ("dd2", "application/vnd.oma.dd2+xml") - , ("ddd", "application/vnd.fujixerox.ddd") - , ("def", "text/plain") - , ("der", "application/x-x509-ca-cert") - , ("dfac", "application/vnd.dreamfactory") - , ("dic", "text/x-c") - , ("dir", "application/x-director") - , ("dis", "application/vnd.mobius.dis") - , ("dist", "application/octet-stream") - , ("distz", "application/octet-stream") - , ("djv", "image/vnd.djvu") - , ("djvu", "image/vnd.djvu") - , ("dll", "application/x-msdownload") - , ("dmg", "application/octet-stream") - , ("dms", "application/octet-stream") - , ("dna", "application/vnd.dna") - , ("doc", "application/msword") - , ("dot", "application/msword") - , ("dp", "application/vnd.osgi.dp") - , ("dpg", "application/vnd.dpgraph") - , ("dsc", "text/prs.lines.tag") - , ("dtd", "application/xml-dtd") - , ("dump", "application/octet-stream") - , ("dvi", "application/x-dvi") - , ("dwf", "model/vnd.dwf") - , ("dwg", "image/vnd.dwg") - , ("dxf", "image/vnd.dxf") - , ("dxp", "application/vnd.spotfire.dxp") - , ("dxr", "application/x-director") - , ("ecelp4800", "audio/vnd.nuera.ecelp4800") - , ("ecelp7470", "audio/vnd.nuera.ecelp7470") - , ("ecelp9600", "audio/vnd.nuera.ecelp9600") - , ("ecma", "application/ecmascript") - , ("edm", "application/vnd.novadigm.edm") - , ("edx", "application/vnd.novadigm.edx") - , ("efif", "application/vnd.picsel") - , ("ei6", "application/vnd.pg.osasli") - , ("elc", "application/octet-stream") - , ("eml", "message/rfc822") - , ("eol", "audio/vnd.digital-winds") - , ("eot", "application/vnd.ms-fontobject") - , ("eps", "application/postscript") - , ("es3", "application/vnd.eszigno3+xml") - , ("esf", "application/vnd.epson.esf") - , ("et3", "application/vnd.eszigno3+xml") - , ("etx", "text/x-setext") - , ("exe", "application/x-msdownload") - , ("ext", "application/vnd.novadigm.ext") - , ("ez", "application/andrew-inset") - , ("ez2", "application/vnd.ezpix-album") - , ("ez3", "application/vnd.ezpix-package") - , ("f", "text/x-fortran") - , ("f77", "text/x-fortran") - , ("f90", "text/x-fortran") - , ("fbs", "image/vnd.fastbidsheet") - , ("fdf", "application/vnd.fdf") - , ("fe_launch", "application/vnd.denovo.fcselayout-link") - , ("fg5", "application/vnd.fujitsu.oasysgp") - , ("fgd", "application/x-director") - , ("fli", "video/x-fli") - , ("flo", "application/vnd.micrografx.flo") - , ("flw", "application/vnd.kde.kivio") - , ("flx", "text/vnd.fmi.flexstor") - , ("fly", "text/vnd.fly") - , ("fm", "application/vnd.framemaker") - , ("fnc", "application/vnd.frogans.fnc") - , ("for", "text/x-fortran") - , ("fpx", "image/vnd.fpx") - , ("frame", "application/vnd.framemaker") - , ("fsc", "application/vnd.fsc.weblaunch") - , ("fst", "image/vnd.fst") - , ("ftc", "application/vnd.fluxtime.clip") - , ("fti", "application/vnd.anser-web-funds-transfer-initiation") - , ("fvt", "video/vnd.fvt") - , ("fzs", "application/vnd.fuzzysheet") - , ("g3", "image/g3fax") - , ("gac", "application/vnd.groove-account") - , ("gdl", "model/vnd.gdl") - , ("ghf", "application/vnd.groove-help") - , ("gif", "image/gif") - , ("gim", "application/vnd.groove-identity-message") - , ("gph", "application/vnd.flographit") - , ("gqf", "application/vnd.grafeq") - , ("gqs", "application/vnd.grafeq") - , ("gram", "application/srgs") - , ("grv", "application/vnd.groove-injector") - , ("grxml", "application/srgs+xml") - , ("gtar", "application/x-gtar") - , ("gtm", "application/vnd.groove-tool-message") - , ("gtw", "model/vnd.gtw") - , ("h", "text/x-c") - , ("h261", "video/h261") - , ("h263", "video/h263") - , ("h264", "video/h264") - , ("hbci", "application/vnd.hbci") - , ("hdf", "application/x-hdf") - , ("hh", "text/x-c") - , ("hlp", "application/winhlp") - , ("hpgl", "application/vnd.hp-hpgl") - , ("hpid", "application/vnd.hp-hpid") - , ("hps", "application/vnd.hp-hps") - , ("hqx", "application/mac-binhex40") - , ("htke", "application/vnd.kenameaapp") - , ("htm", "text/html") - , ("html", "text/html") - , ("hvd", "application/vnd.yamaha.hv-dic") - , ("hvp", "application/vnd.yamaha.hv-voice") - , ("hvs", "application/vnd.yamaha.hv-script") - , ("ico", "image/vnd.microsoft.icon") - , ("ics", "text/calendar") - , ("ief", "image/ief") - , ("ifb", "text/calendar") - , ("ifm", "application/vnd.shana.informed.formdata") - , ("iges", "model/iges") - , ("igl", "application/vnd.igloader") - , ("igs", "model/iges") - , ("igx", "application/vnd.micrografx.igx") - , ("iif", "application/vnd.shana.informed.interchange") - , ("imp", "application/vnd.accpac.simply.imp") - , ("ims", "application/vnd.ms-ims") - , ("in", "text/plain") - , ("ipk", "application/vnd.shana.informed.package") - , ("irm", "application/vnd.ibm.rights-management") - , ("irp", "application/vnd.irepository.package+xml") - , ("iso", "application/octet-stream") - , ("itp", "application/vnd.shana.informed.formtemplate") - , ("ivp", "application/vnd.immervision-ivp") - , ("ivu", "application/vnd.immervision-ivu") - , ("jad", "text/vnd.sun.j2me.app-descriptor") - , ("jam", "application/vnd.jam") - , ("java", "text/x-java-source") - , ("jisp", "application/vnd.jisp") - , ("jlt", "application/vnd.hp-jlyt") - , ("jpe", "image/jpeg") - , ("jpeg", "image/jpeg") - , ("jpg", "image/jpeg") - , ("jpgm", "video/jpm") - , ("jpgv", "video/jpeg") - , ("jpm", "video/jpm") - , ("js", "application/javascript") - , ("json", "application/json") - , ("kar", "audio/midi") - , ("karbon", "application/vnd.kde.karbon") - , ("kfo", "application/vnd.kde.kformula") - , ("kia", "application/vnd.kidspiration") - , ("kml", "application/vnd.google-earth.kml+xml") - , ("kmz", "application/vnd.google-earth.kmz") - , ("kne", "application/vnd.kinar") - , ("knp", "application/vnd.kinar") - , ("kon", "application/vnd.kde.kontour") - , ("kpr", "application/vnd.kde.kpresenter") - , ("kpt", "application/vnd.kde.kpresenter") - , ("ksp", "application/vnd.kde.kspread") - , ("ktr", "application/vnd.kahootz") - , ("ktz", "application/vnd.kahootz") - , ("kwd", "application/vnd.kde.kword") - , ("kwt", "application/vnd.kde.kword") - , ("latex", "application/x-latex") - , ("lbd", "application/vnd.llamagraphics.life-balance.desktop") - , ("lbe", "application/vnd.llamagraphics.life-balance.exchange+xml") - , ("les", "application/vnd.hhe.lesson-player") - , ("lha", "application/octet-stream") - , ("list", "text/plain") - , ("list3820", "application/vnd.ibm.modcap") - , ("listafp", "application/vnd.ibm.modcap") - , ("log", "text/plain") - , ("lrm", "application/vnd.ms-lrm") - , ("ltf", "application/vnd.frogans.ltf") - , ("lvp", "audio/vnd.lucent.voice") - , ("lwp", "application/vnd.lotus-wordpro") - , ("lzh", "application/octet-stream") - , ("m13", "application/x-msmediaview") - , ("m14", "application/x-msmediaview") - , ("m1v", "video/mpeg") - , ("m2a", "audio/mpeg") - , ("m2v", "video/mpeg") - , ("m3a", "audio/mpeg") - , ("m3u", "audio/x-mpegurl") - , ("m4u", "video/vnd.mpegurl") - , ("ma", "application/mathematica") - , ("mag", "application/vnd.ecowin.chart") - , ("maker", "application/vnd.framemaker") - , ("man", "text/troff") - , ("mathml", "application/mathml+xml") - , ("mb", "application/mathematica") - , ("mbk", "application/vnd.mobius.mbk") - , ("mbox", "application/mbox") - , ("mc1", "application/vnd.medcalcdata") - , ("mcd", "application/vnd.mcd") - , ("mdb", "application/x-msaccess") - , ("mdi", "image/vnd.ms-modi") - , ("me", "text/troff") - , ("mesh", "model/mesh") - , ("mfm", "application/vnd.mfmp") - , ("mgz", "application/vnd.proteus.magazine") - , ("mid", "audio/midi") - , ("midi", "audio/midi") - , ("mif", "application/vnd.mif") - , ("mime", "message/rfc822") - , ("mj2", "video/mj2") - , ("mjp2", "video/mj2") - , ("mlp", "application/vnd.dolby.mlp") - , ("mmd", "application/vnd.chipnuts.karaoke-mmd") - , ("mmf", "application/vnd.smaf") - , ("mmr", "image/vnd.fujixerox.edmics-mmr") - , ("mny", "application/x-msmoney") - , ("mov", "video/quicktime") - , ("mp2", "audio/mpeg") - , ("mp2a", "audio/mpeg") - , ("mp3", "audio/mpeg") - , ("mp4", "video/mp4") - , ("mp4a", "audio/mp4") - , ("mp4s", "application/mp4") - , ("mp4v", "video/mp4") - , ("mpc", "application/vnd.mophun.certificate") - , ("mpe", "video/mpeg") - , ("mpeg", "video/mpeg") - , ("mpg", "video/mpeg") - , ("mpg4", "video/mp4") - , ("mpga", "audio/mpeg") - , ("mpkg", "application/vnd.apple.installer+xml") - , ("mpm", "application/vnd.blueice.multipass") - , ("mpn", "application/vnd.mophun.application") - , ("mpp", "application/vnd.ms-project") - , ("mpt", "application/vnd.ms-project") - , ("mpy", "application/vnd.ibm.minipay") - , ("mqy", "application/vnd.mobius.mqy") - , ("mrc", "application/marc") - , ("ms", "text/troff") - , ("mscml", "application/mediaservercontrol+xml") - , ("mseq", "application/vnd.mseq") - , ("msf", "application/vnd.epson.msf") - , ("msh", "model/mesh") - , ("msi", "application/x-msdownload") - , ("msl", "application/vnd.mobius.msl") - , ("mts", "model/vnd.mts") - , ("mus", "application/vnd.musician") - , ("mvb", "application/x-msmediaview") - , ("mwf", "application/vnd.mfer") - , ("mxf", "application/mxf") - , ("mxl", "application/vnd.recordare.musicxml") - , ("mxml", "application/xv+xml") - , ("mxs", "application/vnd.triscape.mxs") - , ("mxu", "video/vnd.mpegurl") - , ("n-gage", "application/vnd.nokia.n-gage.symbian.install") - , ("nb", "application/mathematica") - , ("nc", "application/x-netcdf") - , ("ngdat", "application/vnd.nokia.n-gage.data") - , ("nlu", "application/vnd.neurolanguage.nlu") - , ("nml", "application/vnd.enliven") - , ("nnd", "application/vnd.noblenet-directory") - , ("nns", "application/vnd.noblenet-sealer") - , ("nnw", "application/vnd.noblenet-web") - , ("npx", "image/vnd.net-fpx") - , ("nsf", "application/vnd.lotus-notes") - , ("oa2", "application/vnd.fujitsu.oasys2") - , ("oa3", "application/vnd.fujitsu.oasys3") - , ("oas", "application/vnd.fujitsu.oasys") - , ("obd", "application/x-msbinder") - , ("oda", "application/oda") - , ("odc", "application/vnd.oasis.opendocument.chart") - , ("odf", "application/vnd.oasis.opendocument.formula") - , ("odg", "application/vnd.oasis.opendocument.graphics") - , ("odi", "application/vnd.oasis.opendocument.image") - , ("odp", "application/vnd.oasis.opendocument.presentation") - , ("ods", "application/vnd.oasis.opendocument.spreadsheet") - , ("odt", "application/vnd.oasis.opendocument.text") - , ("ogg", "application/ogg") - , ("oprc", "application/vnd.palm") - , ("org", "application/vnd.lotus-organizer") - , ("otc", "application/vnd.oasis.opendocument.chart-template") - , ("otf", "application/vnd.oasis.opendocument.formula-template") - , ("otg", "application/vnd.oasis.opendocument.graphics-template") - , ("oth", "application/vnd.oasis.opendocument.text-web") - , ("oti", "application/vnd.oasis.opendocument.image-template") - , ("otm", "application/vnd.oasis.opendocument.text-master") - , ("otp", "application/vnd.oasis.opendocument.presentation-template") - , ("ots", "application/vnd.oasis.opendocument.spreadsheet-template") - , ("ott", "application/vnd.oasis.opendocument.text-template") - , ("oxt", "application/vnd.openofficeorg.extension") - , ("p", "text/x-pascal") - , ("p10", "application/pkcs10") - , ("p12", "application/x-pkcs12") - , ("p7b", "application/x-pkcs7-certificates") - , ("p7c", "application/pkcs7-mime") - , ("p7m", "application/pkcs7-mime") - , ("p7r", "application/x-pkcs7-certreqresp") - , ("p7s", "application/pkcs7-signature") - , ("pas", "text/x-pascal") - , ("pbd", "application/vnd.powerbuilder6") - , ("pbm", "image/x-portable-bitmap") - , ("pcl", "application/vnd.hp-pcl") - , ("pclxl", "application/vnd.hp-pclxl") - , ("pct", "image/x-pict") - , ("pcx", "image/x-pcx") - , ("pdb", "application/vnd.palm") - , ("pdb", "chemical/x-pdb") - , ("pdf", "application/pdf") - , ("pfr", "application/font-tdpfr") - , ("pfx", "application/x-pkcs12") - , ("pgm", "image/x-portable-graymap") - , ("pgn", "application/x-chess-pgn") - , ("pgp", "application/pgp-encrypted") - , ("pic", "image/x-pict") - , ("pkg", "application/octet-stream") - , ("pki", "application/pkixcmp") - , ("pkipath", "application/pkix-pkipath") - , ("plb", "application/vnd.3gpp.pic-bw-large") - , ("plc", "application/vnd.mobius.plc") - , ("plf", "application/vnd.pocketlearn") - , ("pls", "application/pls+xml") - , ("pml", "application/vnd.ctc-posml") - , ("png", "image/png") - , ("pnm", "image/x-portable-anymap") - , ("portpkg", "application/vnd.macports.portpkg") - , ("pot", "application/vnd.ms-powerpoint") - , ("ppd", "application/vnd.cups-ppd") - , ("ppm", "image/x-portable-pixmap") - , ("pps", "application/vnd.ms-powerpoint") - , ("ppt", "application/vnd.ms-powerpoint") - , ("pqa", "application/vnd.palm") - , ("prc", "application/vnd.palm") - , ("pre", "application/vnd.lotus-freelance") - , ("prf", "application/pics-rules") - , ("ps", "application/postscript") - , ("psb", "application/vnd.3gpp.pic-bw-small") - , ("psd", "image/vnd.adobe.photoshop") - , ("ptid", "application/vnd.pvi.ptid1") - , ("pub", "application/x-mspublisher") - , ("pvb", "application/vnd.3gpp.pic-bw-var") - , ("pwn", "application/vnd.3m.post-it-notes") - , ("qam", "application/vnd.epson.quickanime") - , ("qbo", "application/vnd.intu.qbo") - , ("qfx", "application/vnd.intu.qfx") - , ("qps", "application/vnd.publishare-delta-tree") - , ("qt", "video/quicktime") - , ("qwd", "application/vnd.quark.quarkxpress") - , ("qwt", "application/vnd.quark.quarkxpress") - , ("qxb", "application/vnd.quark.quarkxpress") - , ("qxd", "application/vnd.quark.quarkxpress") - , ("qxl", "application/vnd.quark.quarkxpress") - , ("qxt", "application/vnd.quark.quarkxpress") - , ("ra", "audio/x-pn-realaudio") - , ("ram", "audio/x-pn-realaudio") - , ("rar", "application/x-rar-compressed") - , ("ras", "image/x-cmu-raster") - , ("rcprofile", "application/vnd.ipunplugged.rcprofile") - , ("rdf", "application/rdf+xml") - , ("rdz", "application/vnd.data-vision.rdz") - , ("rep", "application/vnd.businessobjects") - , ("rgb", "image/x-rgb") - , ("rif", "application/reginfo+xml") - , ("rl", "application/resource-lists+xml") - , ("rlc", "image/vnd.fujixerox.edmics-rlc") - , ("rm", "application/vnd.rn-realmedia") - , ("rmi", "audio/midi") - , ("rmp", "audio/x-pn-realaudio-plugin") - , ("rms", "application/vnd.jcp.javame.midlet-rms") - , ("rnc", "application/relax-ng-compact-syntax") - , ("roff", "text/troff") - , ("rpss", "application/vnd.nokia.radio-presets") - , ("rpst", "application/vnd.nokia.radio-preset") - , ("rs", "application/rls-services+xml") - , ("rsd", "application/rsd+xml") - , ("rss", "application/rss+xml") - , ("rtf", "application/rtf") - , ("rtx", "text/richtext") - , ("s", "text/x-asm") - , ("saf", "application/vnd.yamaha.smaf-audio") - , ("sbml", "application/sbml+xml") - , ("sc", "application/vnd.ibm.secure-container") - , ("scd", "application/x-msschedule") - , ("scm", "application/vnd.lotus-screencam") - , ("sdkd", "application/vnd.solent.sdkm+xml") - , ("sdkm", "application/vnd.solent.sdkm+xml") - , ("sdp", "application/sdp") - , ("see", "application/vnd.seemail") - , ("sema", "application/vnd.sema") - , ("semd", "application/vnd.semd") - , ("semf", "application/vnd.semf") - , ("setpay", "application/set-payment-initiation") - , ("setreg", "application/set-registration-initiation") - , ("sfs", "application/vnd.spotfire.sfs") - , ("sgm", "text/sgml") - , ("sgml", "text/sgml") - , ("sh", "application/x-sh") - , ("shar", "application/x-shar") - , ("shf", "application/shf+xml") - , ("sig", "application/pgp-signature") - , ("silo", "model/mesh") - , ("sit", "application/x-stuffit") - , ("sitx", "application/x-stuffitx") - , ("skd", "application/vnd.koan") - , ("skm", "application/vnd.koan") - , ("skp", "application/vnd.koan") - , ("skt", "application/vnd.koan") - , ("slt", "application/vnd.epson.salt") - , ("smi", "application/smil+xml") - , ("smil", "application/smil+xml") - , ("snd", "audio/basic") - , ("so", "application/octet-stream") - , ("spc", "application/x-pkcs7-certificates") - , ("spf", "application/vnd.yamaha.smaf-phrase") - , ("spl", "application/x-futuresplash") - , ("spot", "text/vnd.in3d.spot") - , ("src", "application/x-wais-source") - , ("ssf", "application/vnd.epson.ssf") - , ("ssml", "application/ssml+xml") - , ("stf", "application/vnd.wt.stf") - , ("stk", "application/hyperstudio") - , ("str", "application/vnd.pg.format") - , ("sus", "application/vnd.sus-calendar") - , ("susp", "application/vnd.sus-calendar") - , ("sv4cpio", "application/x-sv4cpio") - , ("sv4crc", "application/x-sv4crc") - , ("svd", "application/vnd.svd") - , ("svg", "image/svg+xml") - , ("svgz", "image/svg+xml") - , ("swf", "application/x-shockwave-flash") - , ("t", "text/troff") - , ("tao", "application/vnd.tao.intent-module-archive") - , ("tar", "application/x-tar") - , ("tcl", "application/x-tcl") - , ("tex", "application/x-tex") - , ("texi", "application/x-texinfo") - , ("texinfo", "application/x-texinfo") - , ("text", "text/plain") - , ("tif", "image/tiff") - , ("tiff", "image/tiff") - , ("tmo", "application/vnd.tmobile-livetv") - , ("torrent", "application/x-bittorrent") - , ("tpl", "application/vnd.groove-tool-template") - , ("tpt", "application/vnd.trid.tpt") - , ("tr", "text/troff") - , ("tra", "application/vnd.trueapp") - , ("trm", "application/x-msterminal") - , ("tsv", "text/tab-separated-values") - , ("twd", "application/vnd.simtech-mindmapper") - , ("twds", "application/vnd.simtech-mindmapper") - , ("txd", "application/vnd.genomatix.tuxedo") - , ("txf", "application/vnd.mobius.txf") - , ("txt", "text/plain") - , ("ufd", "application/vnd.ufdl") - , ("ufdl", "application/vnd.ufdl") - , ("umj", "application/vnd.umajin") - , ("unityweb", "application/vnd.unity") - , ("uoml", "application/vnd.uoml+xml") - , ("uri", "text/uri-list") - , ("uris", "text/uri-list") - , ("urls", "text/uri-list") - , ("ustar", "application/x-ustar") - , ("utz", "application/vnd.uiq.theme") - , ("uu", "text/x-uuencode") - , ("vcd", "application/x-cdlink") - , ("vcf", "text/x-vcard") - , ("vcg", "application/vnd.groove-vcard") - , ("vcs", "text/x-vcalendar") - , ("vcx", "application/vnd.vcx") - , ("vis", "application/vnd.visionary") - , ("viv", "video/vnd.vivo") - , ("vrml", "model/vrml") - , ("vsd", "application/vnd.visio") - , ("vsf", "application/vnd.vsf") - , ("vss", "application/vnd.visio") - , ("vst", "application/vnd.visio") - , ("vsw", "application/vnd.visio") - , ("vtu", "model/vnd.vtu") - , ("vxml", "application/voicexml+xml") - , ("wav", "audio/wav") - , ("wav", "audio/x-wav") - , ("wax", "audio/x-ms-wax") - , ("wbmp", "image/vnd.wap.wbmp") - , ("wbs", "application/vnd.criticaltools.wbs+xml") - , ("wbxml", "application/vnd.wap.wbxml") - , ("wcm", "application/vnd.ms-works") - , ("wdb", "application/vnd.ms-works") - , ("wks", "application/vnd.ms-works") - , ("wm", "video/x-ms-wm") - , ("wma", "audio/x-ms-wma") - , ("wmd", "application/x-ms-wmd") - , ("wmf", "application/x-msmetafile") - , ("wml", "text/vnd.wap.wml") - , ("wmlc", "application/vnd.wap.wmlc") - , ("wmls", "text/vnd.wap.wmlscript") - , ("wmlsc", "application/vnd.wap.wmlscriptc") - , ("wmv", "video/x-ms-wmv") - , ("wmx", "video/x-ms-wmx") - , ("wmz", "application/x-ms-wmz") - , ("wpd", "application/vnd.wordperfect") - , ("wpl", "application/vnd.ms-wpl") - , ("wps", "application/vnd.ms-works") - , ("wqd", "application/vnd.wqd") - , ("wri", "application/x-mswrite") - , ("wrl", "model/vrml") - , ("wsdl", "application/wsdl+xml") - , ("wspolicy", "application/wspolicy+xml") - , ("wtb", "application/vnd.webturbo") - , ("wvx", "video/x-ms-wvx") - , ("x3d", "application/vnd.hzn-3d-crossword") - , ("xar", "application/vnd.xara") - , ("xbd", "application/vnd.fujixerox.docuworks.binder") - , ("xbm", "image/x-xbitmap") - , ("xdm", "application/vnd.syncml.dm+xml") - , ("xdp", "application/vnd.adobe.xdp+xml") - , ("xdw", "application/vnd.fujixerox.docuworks") - , ("xenc", "application/xenc+xml") - , ("xfdf", "application/vnd.adobe.xfdf") - , ("xfdl", "application/vnd.xfdl") - , ("xht", "application/xhtml+xml") - , ("xhtml", "application/xhtml+xml") - , ("xhvml", "application/xv+xml") - , ("xif", "image/vnd.xiff") - , ("xla", "application/vnd.ms-excel") - , ("xlc", "application/vnd.ms-excel") - , ("xlm", "application/vnd.ms-excel") - , ("xls", "application/vnd.ms-excel") - , ("xlt", "application/vnd.ms-excel") - , ("xlw", "application/vnd.ms-excel") - , ("xml", "application/xml") - , ("xo", "application/vnd.olpc-sugar") - , ("xop", "application/xop+xml") - , ("xpm", "image/x-xpixmap") - , ("xpr", "application/vnd.is-xpr") - , ("xps", "application/vnd.ms-xpsdocument") - , ("xpw", "application/vnd.intercon.formnet") - , ("xpx", "application/vnd.intercon.formnet") - , ("xsl", "application/xml") - , ("xslt", "application/xslt+xml") - , ("xsm", "application/vnd.syncml+xml") - , ("xspf", "application/xspf+xml") - , ("xul", "application/vnd.mozilla.xul+xml") - , ("xvm", "application/xv+xml") - , ("xvml", "application/xv+xml") - , ("xwd", "image/x-xwindowdump") - , ("xyz", "chemical/x-xyz") - , ("zaz", "application/vnd.zzazz.deck+xml") - , ("zip", "application/zip") - , ("zmm", "application/vnd.handheld-entertainment+xml") - , ("avi", "video/x-msvideo") - , ("movie", "video/x-sgi-movie") - , ("ice", "x-conference/x-cooltalk") - ] - diff --git a/src/Network/Protocol/Uri.hs b/src/Network/Protocol/Uri.hs deleted file mode 100644 --- a/src/Network/Protocol/Uri.hs +++ /dev/null @@ -1,622 +0,0 @@ -{- | See rfc2396 for more info. -} - -{-# LANGUAGE TemplateHaskell #-} -module Network.Protocol.Uri ( - - Scheme - , IPv4 - , Domain - , RegName - , Port - , Query - , Fragment - , Hash - , UserInfo - , PathSegment - , Parameters - , Path - , Host - , Authority - , URI - - -- * Creating (parts of) URIs. - - , encode - , decode - - , mkURI - , mkScheme - , mkPath - , mkAuthority - , mkQuery - , mkFragment - , mkUserinfo - , mkHost - , mkPort - - -- * Accessing parts of URIs. - - , domain - , regname - , ipv4 - , userinfo - , host - , port - , relative - , scheme - , authority - , path - , query - , fragment - - -- * Helper labels. - - , absolute - , segments - , _host - , _port - - -- * Parsing URIs. - - , parseURI - , parseAbsoluteURI - , parseAuthority - , parsePath - , parseHost - - , pUriReference - , pAbsoluteURI --- , pAuthority --- , pPath --- , pHost - - -- * Handling query parameters. - - , parseQueryParams - , queryParams - - -- * Filename related utilities. - - , extension - - , mkPathRelative - , mimetype - , normalize - , jail - , (/+) - - ) where - -import Control.Applicative -import Data.Bits -import Data.Char (ord, chr, isDigit, isAlphaNum, intToDigit, isHexDigit, toLower) -import Data.List (intercalate, isPrefixOf) -import Data.Maybe (mapMaybe, fromJust) -import Data.Record.Label -import Misc.Misc (eitherToMaybe, (@@), bool, pMaybe, split) -import Network.Protocol.Mime -import System.FilePath.Posix -import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) - --------[ data type definition of URIs ]---------------------------------------- - -type Scheme = String -type IPv4 = [Int] -- actually 4-tupel -type Domain = [String] -type RegName = String -type Port = Int -type Query = String -type Fragment = String -type Hash = String -type UserInfo = String -type PathSegment = String -type Parameters = [(String, Maybe String)] - -data Path = Path { - _absolute :: Bool - , _segments :: [PathSegment] - } - deriving (Eq, Ord) - -data Host = - Hostname { __domain :: Domain } - | RegName { __regname :: String } - | IPv4 { __ipv4 :: IPv4 } - deriving (Eq, Ord) - -data Authority = Authority { - __userinfo :: UserInfo - , __host :: Host - , __port :: Port - } - deriving (Eq, Ord) - -data URI = URI { - _relative :: Bool - , _scheme :: Scheme - , _authority :: Authority - , __path :: Path - , __query :: Query - , _fragment :: Fragment - } - deriving (Eq, Ord) - -$(mkLabels [''Path, ''Host, ''Authority, ''URI]) - -_domain :: Label Host Domain -_host :: Label Authority Host -_ipv4 :: Label Host IPv4 -_path :: Label URI Path -_port :: Label Authority Port -_query :: Label URI Query -_regname :: Label Host String -_userinfo :: Label Authority UserInfo -absolute :: Label Path Bool -authority :: Label URI Authority -domain :: Label URI Domain -fragment :: Label URI Fragment -host :: Label URI String -ipv4 :: Label URI IPv4 -path :: Label URI FilePath -port :: Label URI Port -query :: Label URI Query -regname :: Label URI String -relative :: Label URI Bool -scheme :: Label URI Scheme -segments :: Label Path [PathSegment] -userinfo :: Label URI UserInfo - --- Public label based on private labels. - -domain = _domain % _host % authority -regname = _regname % _host % authority -ipv4 = _ipv4 % _host % authority -userinfo = _userinfo % authority -port = _port % authority - -query = Label - (decode . lget _query) - (lset _query . encode) - -host = Label - (show . lget (_host % authority)) - (lset (_host % authority) . maybe (Hostname []) id . parseHost) - -path = Label - (decode . show . lget _path) - (lset _path . maybe (Path True []) id . parsePath . encode) - --------[ creating, selection and modifying URIs ]------------------------------ - -{- | Constructors for making empty URI. -} - -mkURI :: URI -mkURI = URI False mkScheme mkAuthority mkPath mkQuery mkFragment - -{- | Constructors for making empty `Scheme`. -} - -mkScheme :: Scheme -mkScheme = "" - -{- | Constructors for making empty `Path`. -} - -mkPath :: Path -mkPath = Path False [] - -{- | Constructors for making empty `Authority`. -} - -mkAuthority :: Authority -mkAuthority = Authority "" mkHost mkPort - -{- | Constructors for making empty `Query`. -} - -mkQuery :: Query -mkQuery = "" - -{- | Constructors for making empty `Fragment`. -} - -mkFragment :: Fragment -mkFragment = "" - -{- | Constructors for making empty `UserInfo`. -} - -mkUserinfo :: UserInfo -mkUserinfo = "" - -{- | Constructors for making empty `Host`. -} - -mkHost :: Host -mkHost = Hostname [] - -{- | Constructors for making empty `Port`. -} - -mkPort :: Port -mkPort = (-1) - --------[ path encoding and decoding ]------------------------------------------ - -{- | URI encode a string. -} - -encode :: String -> String -encode = concatMap encodeChr - where - encodeChr c - | unreserved c || genDelims c || subDelims c = [c] - | otherwise = '%' : - intToDigit (shiftR (ord c) 4) : - intToDigit ((ord c) .&. 0x0F) : [] - -{- | URI decode a string. -} - -decode :: String -> String -decode [] = [] -decode ('%':d:e:ds) | isHexDigit d && isHexDigit e = (chr $ digs d * 16 + digs e) : decode ds - where digs a = fromJust $ lookup (toLower a) $ zip "0123456789abcdef" [0..] -decode (d:ds) = d : decode ds - --------[ show instance for URIs ]---------------------------------------------- - --- TODO: cleanup and test this mess: QuickCheck property for testing: --- parse $ show u == u /\ show $ parse u' = u' - --- TODO: ShowS - -instance Show Path where - show (Path a s) = - (if a then "/" else "") - ++ (intercalate "/" s) - -instance Show Host where - show (Hostname d) = if null d then "" else intercalate "." d - show (IPv4 a) = intercalate "." $ map show a - show (RegName r) = r - -instance Show Authority where - show (Authority u h p) = - (if hst h then "//" else "") - ++ (if null u then "" else u ++ "@") - ++ show h - ++ (if p == -1 then "" else ":" ++ show p) - where hst (Hostname d) = not $ null d - hst (RegName d) = not $ null d - hst _ = True - -instance Show URI where - show (URI r s a p q f) = - (if not r then (if null s then "" else s ++ ":") else "") - ++ (show a) - ++ (show p) - ++ (if null q then "" else "?" ++ q) - ++ (if null f then "" else "#" ++ f) - --------[ global URI parse interface ]------------------------------------------ - -{- | Parse string into a `URI`. -} - -parseURI :: String -> Maybe URI -parseURI = eitherToMaybe . parse pUriReference "" - -{- | Parse string into a `URI` and only accept absolute URIs. -} - -parseAbsoluteURI :: String -> Maybe URI -parseAbsoluteURI = eitherToMaybe . parse pAbsoluteURI "" - -{- | Parse string into a `Authority` object. -} - -parseAuthority :: String -> Maybe Authority -parseAuthority = eitherToMaybe . parse pAuthority "" - -{- | Parse string into a `Path`. -} - -parsePath :: String -> Maybe Path -parsePath = eitherToMaybe . parse pPath "" - -{- | Parse string into a `Host`. -} - -parseHost :: String -> Maybe Host -parseHost = eitherToMaybe . parse pHost "" - --------[ parsing URIs according to rfc2396 ]----------------------------------- - --- D.2. Modifications -pAlpha, pDigit, pAlphanum :: GenParser Char st Char - -pAlpha = letter -pDigit = digit -pAlphanum = alphaNum - --- 2.3. Unreserved Characters -unreserved :: Char -> Bool -unreserved c = isAlphaNum c || elem c "-._~" - -pUnreserved :: GenParser Char st Char -pUnreserved = pAlphanum <|> oneOf "-._~" - --- 2.2. Reserved Characters -genDelims :: Char -> Bool -genDelims = flip elem ":/?#[]@" - -subDelims :: Char -> Bool -subDelims = flip elem "!$&'()*+,;=" - -{- -pReserved :: GenParser Char st Char -pReserved = pGenDelims <|> pSubDelims -pGenDelims :: GenParser Char st Char -pGenDelims = oneOf ":/?#[]@" --} - -pSubDelims :: GenParser Char st Char -pSubDelims = oneOf "!$&'()*+,;=" - --- 2.1. Percent-Encoding -pPctEncoded :: GenParser Char st String -pPctEncoded = (:) <$> char '%' <*> pHex - -pHex :: GenParser Char st String -pHex = (\a b -> a:b:[]) - <$> hexDigit - <*> hexDigit - --- 3. Syntax Components - --- With the hier-part integrated. -pUri :: GenParser Char st URI -pUri = (\a (b,c) d e -> URI False a b c d e) - <$> (pScheme <* string ":") - <*> (ap <|> p) - <*> option "" (string "?" *> pQuery) - <*> option "" (string "#" *> pFragment) - where - ap = (,) <$> (string "//" *> pAuthority) <*> pPathAbempty - p = ((,) mkAuthority) <$> (pPathAbsolute <|> pPathRootless {-<|> pPathEmpty-}) - --- 3.1. Scheme -pScheme :: GenParser Char st Scheme -pScheme = (:) <$> pAlpha <*> many (pAlphanum <|> oneOf "+_.") - --- 3.2. Authority -pAuthority :: GenParser Char st Authority -pAuthority = Authority - <$> option mkUserinfo (try (pUserinfo <* string "@")) - <*> pHost - <*> option mkPort (string ":" *> pPort) - --- 3.2.1. User Information -pUserinfo :: GenParser Char st String -pUserinfo = concat <$> many ( - (pure <$> pUnreserved) - <|> ( pPctEncoded) - <|> (pure <$> pSubDelims) - <|> (pure <$> oneOf ":") - ) - --- 3.2.2. Host -pHost :: GenParser Char st Host -pHost = diff <$> pRegName -- <|> RegName <$> pRegName - where - diff a = maybe (RegName a) sep (pHostname @@ a) - sep a = bool (Hostname a) (ipreg a) $ hst a - ipreg a = bool (IPv4 $ map read a) (RegName $ intercalate "." a) $ ip a - hst = not . all isDigit . head . dropWhile null . reverse - ip a = length a == 4 && length (mapMaybe (pDecOctet @@) a) == 4 - -{- -pfff, ipv6 is sooo not gonna make it.. - -pIPLiteral = "[" ( IPv6address <|> IPvFuture ) "]" - -pIPvFuture = "v" 1*HEXDIG "." 1*( unreserved <|> subDelims <|> ":" ) - -pIPv6address = - 6( h16 ":" ) ls32 - <|> "::" 5( h16 ":" ) ls32 - <|> [ h16 ] "::" 4( h16 ":" ) ls32 - <|> [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32 - <|> [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32 - <|> [ *3( h16 ":" ) h16 ] "::" h16 ":" ls32 - <|> [ *4( h16 ":" ) h16 ] "::" ls32 - <|> [ *5( h16 ":" ) h16 ] "::" h16 - <|> [ *6( h16 ":" ) h16 ] "::" - -pH16 = 1*4HEXDIG -pLs32 = ( h16 ":" h16 ) <|> IPv4address --} - -{- -pIPv4address :: GenParser Char st [Int] -pIPv4address = (:) <$> pDecOctet <*> (count 3 $ char '.' *> pDecOctet) --} - -pDecOctet :: GenParser Char st Int -pDecOctet = read <$> choice [ - try ((\a b c -> [a,b,c]) <$> char '2' <*> char '5' <*> oneOf "012345") - , try ((\a b c -> [a,b,c]) <$> char '2' <*> oneOf "01234" <*> digit) - , try ((\a b c -> [a,b,c]) <$> char '1' <*> digit <*> digit) - , try ((\a b -> [a,b]) <$> digit <*> digit) - , (pure <$> digit) - ] - -pRegName :: GenParser Char st String -pRegName = concat <$> many1 ( - (pure <$> pUnreserved) - <|> pPctEncoded - <|> (pure <$> pSubDelims)) - --- Not actually part of the rfc3986, but comptability with the rfc2396. --- This information can be useful, so why throw away. -pHostname :: GenParser Char st Domain -pHostname = sepBy (option "" pDomainlabel) (string ".") - -pDomainlabel :: GenParser Char st String -pDomainlabel = intercalate "-" <$> sepBy1 (some pAlphanum) (string "-") - --- 3.2.3. Port -pPort :: GenParser Char st Port -pPort = read <$> some pDigit - --- 3.4. Query -pQuery :: GenParser Char st String -pQuery = concat <$> many (pPchar <|> pure <$> oneOf "/?") - --- 3.5. Fragment -pFragment :: GenParser Char st String -pFragment = concat <$> many (pPchar <|> pure <$> oneOf "/?" ) - --- 3.3. Path - -pPath, pPathAbempty, pPathAbsolute, pPathNoscheme, pPathRootless, pPathEmpty - :: GenParser Char st Path - -pPath = - try pPathAbsolute -- begins with "/" but not "//" - <|> try pPathNoscheme -- begins with a nonColon segment - <|> try pPathRootless -- begins with a segment - <|> pPathEmpty -- zero characters - -pPathAbempty = (Path True) <$> _pSlashSegments -pPathAbsolute = (char '/' *>) $ (Path True) <$> (option [] $ (:) <$> pSegmentNz <*> _pSlashSegments) -pPathNoscheme = (Path False) <$> ((:) <$> pSegmentNzNc <*> _pSlashSegments) -pPathRootless = (Path False) <$> ((:) <$> pSegmentNz <*> _pSlashSegments) -pPathEmpty = (Path False []) <$ string "" - -pSegment, pSegmentNz, pSegmentNzNc :: GenParser Char st String -pSegment = concat <$> many pPchar -pSegmentNz = concat <$> some pPchar -pSegmentNzNc = concat <$> some ( - (pure <$> pUnreserved) - <|> pPctEncoded - <|> (pure <$> pSubDelims) - <|> (pure <$> oneOf "@" )) - -_pSlashSegments :: GenParser Char st [PathSegment] -_pSlashSegments = (many $ (:) <$> char '/' *> pSegment) - -pPchar :: GenParser Char st String -pPchar = choice [ - pure <$> pUnreserved - , pPctEncoded - , pure <$> pSubDelims - , pure <$> oneOf ":@" - ] - --- 4.1. URI Reference - -pUriReference :: GenParser Char st URI -pUriReference = try pAbsoluteURI <|> pRelativeRef - --- 4.2. Relative Reference - --- With the relative-part integrated. -pRelativeRef :: GenParser Char st URI -pRelativeRef = ($) - <$> (try pRelativePart - <|> ((URI True mkScheme mkAuthority) - <$> (pPathAbsolute <|> pPathRootless <|> pPathEmpty))) - <*> option "" (string "?" *> pQuery) - <*> option "" (string "#" *> pFragment) - -pRelativePart :: GenParser Char st (Query -> Fragment -> URI) -pRelativePart = (URI True mkScheme) <$> (string "//" *> pAuthority) <*> pPathAbempty - --- 4.3. Absolute URI - -pAbsoluteURI :: GenParser Char st URI -pAbsoluteURI = pUri - --------[ parsing query parameters ]-------------------------------------------- - -pQueryParams :: GenParser Char st Parameters -pQueryParams = - filter (not . null . fst) - <$> sepBy ((,) - <$> many (noneOf "=&") - <*> pMaybe (char '=' - *> (translateParam <$> many (noneOf "&")))) - (char '&') - -{- | Parse a pre-decoded query string into key value pairs parameters. -} - -parseQueryParams :: String -> Maybe Parameters -parseQueryParams = eitherToMaybe . parse pQueryParams "" - -{- | Fetch the query parameters form a URI. -} - -queryParams :: URI -> Parameters -queryParams = maybe [] id . parseQueryParams . lget query - --- Translate special characters in a parameter. -translateParam :: String -> String -translateParam [] = [] -translateParam ('+':xs) = ' ' : translateParam xs -translateParam (x:xs) = x : translateParam xs - --------[ filename path utilities ]--------------------------------------------- - -{- | Label to access the extension of a filename. -} - -extension :: Label FilePath (Maybe String) -extension = Label {lget = getExt, lset = setExt} - where - splt p = (\(a,b) -> (reverse a, reverse b)) $ break (=='.') $ reverse p - isExt e p = '/' `elem` e || not ('.' `elem` p) - getExt p = let (u, v) = splt p in - if isExt u v then Nothing else Just u - setExt e p = let (u, v) = splt p in - (if isExt u v then p else init v) ++ maybe "" ('.':) e - -{- | -Try to guess the correct mime type for the input file based on the file -extension. --} - -mimetype :: FilePath -> Maybe String -mimetype p = lget extension p >>= mime - -{- | -Normalize a path by removing or merging all dot or dot-dot segments and double -slashes. --} - --- Todo: cleanup, remove fixp. - -normalize :: FilePath -> FilePath -normalize [] = [] -normalize p = fixAbs absolut $ intercalate "/" $ norm - where - fixAbs True = ('/':) - fixAbs False = id - absolut = head p == '/' - norm = fixp False $ split '/' p - fixp False xs = let ys = merge xs in fixp (xs == ys) ys - fixp True xs = xs - merge ("":xs) = merge xs - merge (".":xs) = merge xs - merge ("..":"..":xs) = ".." : ".." : merge xs - merge (_:"..":xs) = merge xs - merge (x:xs) = x : merge xs - merge xs = xs - -{- | Make a path relative by removing the first slash when there is one. -} - -mkPathRelative :: FilePath -> FilePath -mkPathRelative = dropWhile (=='/') - -{- | Jail a filepath within a jail directory. -} - -jail - :: FilePath -- ^ Jail directory. - -> FilePath -- ^ Filename to jail. - -> Maybe FilePath -jail jailDir p = - let nj = normalize jailDir - np = normalize p in - if nj `isPrefixOf` np -- && not (".." `isPrefixOf` np) - then Just np - else Nothing - -{- | Concatenate and normalize two filepaths. -} - -(/+) :: FilePath -> FilePath -> FilePath -a /+ b = normalize (a ++ "/" ++ b) - diff --git a/src/Network/Salvia.hs b/src/Network/Salvia.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia.hs @@ -0,0 +1,10 @@ +module Network.Salvia +( module Network.Salvia.Interface +, module Network.Salvia.Handlers +, module Network.Salvia.Impl +) +where + +import Network.Salvia.Interface +import Network.Salvia.Handlers +import Network.Salvia.Impl diff --git a/src/Network/Salvia/Core/Config.hs b/src/Network/Salvia/Core/Config.hs deleted file mode 100644 --- a/src/Network/Salvia/Core/Config.hs +++ /dev/null @@ -1,44 +0,0 @@ -module Network.Salvia.Core.Config ( - HttpdConfig (..) - , defaultConfig - ) where - -import Network.Socket hiding (send, listen) -import System.IO - -{- | -The HTTP server configuration specifies some important network settings the -server must know before being able to run. Most fields speak for themselves. --} - -data HttpdConfig = - HttpdConfig { - hostname :: String -- ^ Server hostname. - , email :: String -- ^ Server admin email address. - , listenAddr :: HostAddress -- ^ Addres to bind to. - , listenPort :: PortNumber -- ^ Port to listen on. - , backlog :: Int -- ^ TCP backlog. - , bufferSize :: Int -- ^ Serve chunck with size. - } - -{- | -The default server configuration sets some safe default values. The server will -by default bind to 0.0.0.0 at port 80. The default value for the TCP backlog is -4, the default socket buffer size is 64KB. This function has to be in IO -because of the translation from a `String` to a `HostAddress` using -`inet_addr`. --} - -defaultConfig :: IO HttpdConfig -defaultConfig = do - addr <- inet_addr "0.0.0.0" - return - $ HttpdConfig { - hostname = "hostname" - , email = "admin@localhost" - , listenAddr = addr - , listenPort = 80 - , backlog = 4 - , bufferSize = 64 * 1024 - } - diff --git a/src/Network/Salvia/Core/Context.hs b/src/Network/Salvia/Core/Context.hs deleted file mode 100644 --- a/src/Network/Salvia/Core/Context.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} -module Network.Salvia.Core.Context ( - SendAction - , SendQueue - , Context - - , config - , request - , response - , sock - , address - , queue - - , mkContext - ) where - -import Data.Record.Label -import Network.Protocol.Http (Message, emptyRequest, emptyResponse) -import Network.Salvia.Core.Config -import Network.Socket (SockAddr) -import System.IO - --------- single request/response context -------------------------------------- - --- | A send action is some thing that works on an IO handle. -type SendAction = Handle -> IO () - -{- | -The send queue is an abstraction to make sure all data that belongs to the -message body is sent after the response headers have been sent. Instead of -sending data to client directly over the socket from the context it is -preferable to queue send actions in the context's send queue. The entire send -queue can be flushed to the client at once after the HTTP headers have been -sent at the end of a request handler. --} - -type SendQueue = [SendAction] - -{- | -A handler context contains all the information needed by the request handlers -to perform their task and to set up a proper response. All the fields in the -context are accessible using the read/write labels defined below. --} - -data Context = - Context { - _config :: HttpdConfig -- ^ The HTTP server configuration. - , _request :: Message -- ^ The HTTP request header. - , _response :: Message -- ^ The HTTP response header. - , _sock :: Handle -- ^ The socket handle for the connection with the client. - , _address :: SockAddr -- ^ The client addres. - , _queue :: SendQueue -- ^ The queue of send actions. - } - -$(mkLabels [''Context]) - -{- | The queue containing all send actions. -} -queue :: Label Context SendQueue - -{- | The client address. -} -address :: Label Context SockAddr - -{- | The socket to the client. -} -sock :: Label Context Handle - -{- | -The server response. Using the appropriate handler the response can be sent to -the client after processing the request. --} - -response :: Label Context Message - -{- | -The client request. This request is initially empty and only available after -the message has been parsed by the appropriate handler. --} - -request :: Label Context Message - -{- | -The global server configuration. Modifying this has no effect on consecutive -requests. --} - -config :: Label Context HttpdConfig - -{- | -Create and default server context with the specified server configuration, -client address and socket. --} - -mkContext :: HttpdConfig -> SockAddr -> Handle -> Context -mkContext c a s = Context { - _config = c - , _request = emptyRequest - , _response = emptyResponse -- 200 OK, by default. - , _sock = s - , _address = a - , _queue = [] - } - diff --git a/src/Network/Salvia/Core/Handler.hs b/src/Network/Salvia/Core/Handler.hs deleted file mode 100644 --- a/src/Network/Salvia/Core/Handler.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TemplateHaskell #-} - -module Network.Salvia.Core.Handler ( - Handler - , ResourceHandler - , UriHandler - ) where - -import Control.Applicative (Applicative, pure, (<*>)) -import Control.Monad.State (StateT, ap) -import Network.Protocol.Uri (URI) -import Network.Salvia.Core.Context -import System.IO - -{- | -A HTTP request handler lives in `IO` and carries a server context in the -`State` monad. This module also provides an `Applicative` instance for `StateT` -`Context` `IO`. --} - -type Handler a = StateT Context IO a - -{- | A resource handler is something that works on some filesystem resource. -} - -type ResourceHandler a = FilePath -> Handler a - -{- | A URI handler is something that works on an request URI. -} - -type UriHandler a = URI -> Handler a - --- Make handlers applicative. -instance Applicative (StateT Context IO) where - pure = return - (<*>) = ap - diff --git a/src/Network/Salvia/Core/IO.hs b/src/Network/Salvia/Core/IO.hs deleted file mode 100644 --- a/src/Network/Salvia/Core/IO.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-| -This module contains some useful functions for IO over the client socket. Some -functions directly work on the socket and some queue actions into the send -queue. The latter form is more high-level and recommended for common use. This -module is likely to be extended in the future with other useful function that -handle specific message IO. --} - -module Network.Salvia.Core.IO ( - - -- * Queing send actions to the send queue. - send - , sendStr - , sendStrLn - , sendBs - - -- * Queing spool actions to the send queue. - , spool - , spoolBs - - -- * Send actions directly using the socket. - , flushHeaders - , flushQueue - - -- * Directly manipulate the send queue. - , emptyQueue - , reset - - -- * Reading data from the client request. - , contents - , contentsUtf8 - , uriEncodedPostParamsUTF8 - - ) where - --- TODO: we are mixing two encoding libs. fix. - -import Control.Monad.State -import Data.Encoding (decodeLazyByteString) -import Data.Encoding.UTF8 -import Data.Record.Label -import Network.Protocol.Http -import Network.Protocol.Uri (Parameters, parseQueryParams, decode) -import Network.Salvia.Core.Context -import Network.Salvia.Core.Handler -import System.IO -import qualified Data.ByteString.Lazy as B -import qualified System.IO.UTF8 as U - -------------------------------------------------------------------------------- - -{- | -Queue one potential send action in the send queue. This will not (yet) be sent -over the socket. --} - -send :: SendAction -> Handler () -send f = modM queue (++[f]) - -{- | Queue the action of sending one UTF-8 encoded `String` over the socket. -} - -sendStr :: String -> Handler () -sendStr s = send (flip U.hPutStr s) - -{- | -Queue the action of sending one UTF-8 encoded `String` with extra linefeed -over the socket. --} - -sendStrLn :: String -> Handler () -sendStrLn s = send (flip U.hPutStr (s ++ "\n")) - -{- | Queue the action of sending one lazy `B.ByteString` over the socket. -} - -sendBs :: B.ByteString -> Handler () -sendBs bs = send (flip B.hPutStr bs) - -{- | -Queue spooling the entire contents of a stream to the socket using a UTF-8 -encoded `String` based filter. --} - -spool :: (String -> String) -> Handle -> Handler () -spool f fd = send (\s -> U.hGetContents fd >>= \d -> U.hPutStr s (f d)) - -{- | -Queue spooling the entire contents of a stream to the socket using a -`B.ByteString` based filter. --} - -spoolBs :: (B.ByteString -> B.ByteString) -> Handle -> Handler () -spoolBs f fd = send (\s -> B.hGetContents fd >>= \d -> B.hPut s (f d)) - -{- | Send all the response headers directly over the socket. -} - -flushHeaders :: Handler () -flushHeaders = do - r <- getM response - s <- getM sock - lift $ hPutStr s (showMessageHeader r) - -{- | Apply all send actions successively to the client socket. -} - -flushQueue :: Handler () -flushQueue = - do h <- getM sock - q <- getM queue - liftIO $ - do mapM_ ($ h) q - hFlush h - -{- | Reset the send queue by throwing away all potential send actions. -} - -emptyQueue :: Handler () -emptyQueue = setM queue [] - -{- | Reset both the send queue and the generated server response. -} - -reset :: Handler () -reset = do - setM response emptyResponse - emptyQueue - -{- | -First (possibly naive) handler to retreive the client request body as a -`B.ByteString`. This probably does not handle all the quirks that the HTTP -protocol specifies, but it does the job for now. When a 'contentLength' header -field is available only this fixed number of bytes will read from the socket. -When neither the 'keepAlive' and 'contentLength' header fields are available -the entire payload of the request will be read from the socket. This method is -probably only useful in the case of 'PUT' request, because no decoding of -'POST' data is handled. --} - -contents :: Handler (Maybe B.ByteString) -contents = do - len <- getM (contentLength % request) - kpa <- getM (keepAlive % request) - s <- getM sock - lift $ - case (kpa::Maybe Integer, len::Maybe Integer) of - (_, Just n) -> liftM Just (B.hGet s (fromIntegral n)) - (Nothing, Nothing) -> liftM Just (B.hGetContents s) - _ -> return Nothing - -{- | -Like the `contents' function but decodes the data as UTF-8. Soon, time will -come that decoding will be based upon the requested encoding. --} - -contentsUtf8 :: Handler (Maybe String) -contentsUtf8 = (fmap $ decodeLazyByteString UTF8) `liftM` contents - -{- | -Try to parse the supplied request body as URI encoded `POST` parameters in -UTF-8 encoding. Returns as a URI parameter type or nothing when parsing fails. --} - -uriEncodedPostParamsUTF8 :: Handler (Maybe Parameters) -uriEncodedPostParamsUTF8 = liftM (>>= parseQueryParams . decode) contentsUtf8 - diff --git a/src/Network/Salvia/Core/Main.hs b/src/Network/Salvia/Core/Main.hs deleted file mode 100644 --- a/src/Network/Salvia/Core/Main.hs +++ /dev/null @@ -1,59 +0,0 @@ -module Network.Salvia.Core.Main (start) where - -import Control.Concurrent (forkIO) -import Control.Monad.State -import Network.Salvia.Core.Config (listenAddr, listenPort, backlog, HttpdConfig) -import Network.Salvia.Core.Context (mkContext) -import Network.Salvia.Core.Handler (Handler) -import Network.Socket -import System.IO - --------- HTTP deamon implementation ------------------------------------------- - -{- | -Start a webserver with a specific server configuration and default handler. The -server will go into an infinite loop and will repeatedly accept client -connections on the address and port specified in the configuration. For every -connection the specified handler will be executed with the client address and -socket stored in the handler context. --} - -start :: HttpdConfig -> Handler () -> IO () -start config httpHandler = - server - (listenAddr config) - (listenPort config) - (backlog config) - tcpHandler - where - tcpHandler handle addr = - fst `liftM` runStateT httpHandler - (mkContext config addr handle) - -{- -Start a listening TCP server on the specified address/port combination and -handle every connection with a custom handler. --} - -server :: HostAddress -> PortNumber -> Int -> (Handle -> SockAddr -> IO ()) -> IO () -server addr port blog handler = do - sock <- socket AF_INET Stream 0 - setSocketOption sock ReuseAddr 1 - bindSocket sock $ SockAddrInet port addr - listen sock blog - acceptLoop sock handler - -{- -Accept connections on the listening socket and pass execution to the -application specific connection handler. --} - -acceptLoop :: Socket -> (Handle -> SockAddr -> IO ()) -> IO () -acceptLoop sock handler = do - forever $ do - (sock', addr) <- accept sock - forkIO $ - do h <- socketToHandle sock' ReadWriteMode - handler h addr - putStrLn "quiting" - diff --git a/src/Network/Salvia/Handler/Banner.hs b/src/Network/Salvia/Handler/Banner.hs --- a/src/Network/Salvia/Handler/Banner.hs +++ b/src/Network/Salvia/Handler/Banner.hs @@ -1,28 +1,31 @@ +{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.Banner (hBanner) where +import Control.Applicative import Control.Monad.State import Data.Record.Label -import Data.Time.Clock (getCurrentTime) -import Data.Time.Format (formatTime) -import Data.Time.LocalTime (getCurrentTimeZone, utcToLocalTime) +import Data.Time.Clock +import Data.Time.Format +import Data.Time.LocalTime import Network.Protocol.Http -import Network.Salvia.Httpd -import System.Locale (defaultTimeLocale) +import Network.Salvia.Interface +import System.Locale {- | The 'hBanner' handler adds the current date-/timestamp and a custom server name to the response headers. -} -hBanner :: - String -- ^ The HTTP server name. - -> Handler () -hBanner sv = do - dt <- lift $ do - zone <- getCurrentTimeZone - time <- liftM (utcToLocalTime zone) getCurrentTime - return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" time - enterM response $ do - setM date dt - setM server sv +hBanner + :: (MonadIO m, HttpM Response m) + => String -- ^ The name to include as the /Server/ header line. + -> m () +hBanner sv = + do dt <- liftIO $ + do zone <- getCurrentTimeZone + time <- utcToLocalTime zone <$> getCurrentTime + return $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" time + response $ + do date =: Just dt + server =: Just sv diff --git a/src/Network/Salvia/Handler/Body.hs b/src/Network/Salvia/Handler/Body.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Handler/Body.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE FlexibleContexts, RankNTypes, ScopedTypeVariables #-} +module Network.Salvia.Handler.Body +( hRawRequestBody +, hRawResponseBody +, hRawBody + +, hRequestBodyText +, hResponseBodyText +, hBodyText + +, hRequestBodyStringUTF8 +, hResponseBodyStringUTF8 +, hBodyStringUTF8 + +, hRequestParameters +, hResponseParameters +, hParameters +) +where + +import Control.Applicative +import Control.Monad.State hiding (get) +import Data.Char +import Data.Record.Label +import Data.Text.Lazy (Text, unpack) +import Data.Text.Lazy.Encoding +import Network.Protocol.Http +import Network.Protocol.Uri +import Network.Salvia.Interface +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.UTF8 as U + +-- | Lookup an Data.Text encoding function from a named identifier, currently +-- identifies "utf-8", "utf-16", "utf-32" with possible little/big endian +-- postfixes ("le", "be"). The comparision is quite fuzzy so, for example, both +-- "UTF16le" and "utf-16-LE" will be mapped to the same decoder. + +encodingFromName :: String -> Maybe (B.ByteString -> Text) +encodingFromName s = k `lookup` + [ ("utf8", decodeUtf8) +-- , ("utf16", decodeUtf16LE) +-- , ("utf16le", decodeUtf16LE) +-- , ("utf16be", decodeUtf16BE) +-- , ("utf32", decodeUtf32LE) +-- , ("utf32le", decodeUtf32LE) +-- , ("utf32be", decodeUtf32BE) + ] where k = map toLower (filter (\c -> isAlpha c || isDigit c) s) + +{- | +First (possibly naive) handler to retreive the client request or server +response body as a raw lazy `B.ByteString`. This probably does not handle all +the quirks that the HTTP protocol specifies, but it does the job for now. When +a 'contentLength' header field is available only this fixed number of bytes +will read from the socket. When neither the 'keepAlive' and 'contentLength' +header fields are available the entire payload of the request will be read from +the socket. The function is parametrized with a the direction of the HTTP +message, client request or server response. +-} + +hRawBody :: forall m d. (MonadIO m, HandleM m, HttpM d m) => d -> m B.ByteString +hRawBody _ = + do let h = http :: State (Http d) a -> m a + con <- h (getM connection) + kpa <- h (getM keepAlive) + len <- h (getM contentLength) + s <- handle + liftIO $ + case (con, kpa :: Maybe Integer, len :: Maybe Integer) of + (_, _, Just n) -> B.hGet s (fromIntegral n) + (k, Nothing, Nothing) | k /= Just "keep-alive" -> B.hGetContents s + _ -> return B.empty + +-- | Like `hRawBody' but specifically for `Http' `Request's. + +hRawRequestBody :: BodyM Request m => m B.ByteString +hRawRequestBody = body forRequest + +-- | Like `hRawBody' but specifically for `Http' `Request's. + +hRawResponseBody :: BodyM Response m => m B.ByteString +hRawResponseBody = body forResponse + +{- | +Like the `hRawBody' but is will handle proper decoding based on the charset +part of the `contentType' header line. When a valid encoding is found in the +`Http' message it will be decoded with using the encodings package. The default +encoding supplied as the function's argument can be used to specify what +encoding to use in the absence of a proper encoding in the HTTP message itself. +-} + +hBodyText :: forall m dir. (BodyM dir m, HttpM dir m) => dir -> String -> m Text +hBodyText d def = + do let h = http :: State (Http dir) a -> m a + c <- body d + e <- (>>= snd) <$> h (getM contentType) :: m (Maybe String) + return $ + case (e >>= encodingFromName, encodingFromName def) of + (Just enc, _) -> enc c + (_, Just enc) -> enc c + (_, _) -> error "hBodyText: wrong default encoding specified" + +-- | Like `hBodyText' but specifically for `Http' `Request's. + +hRequestBodyText :: (BodyM Request m, HttpM Request m) => String -> m Text +hRequestBodyText = hBodyText forRequest + +-- | Like `hBodyText' but specifically for `Http' `Response's. + +hResponseBodyText :: (BodyM Response m, HttpM Response m) => String -> m Text +hResponseBodyText = hBodyText forResponse + +-- | Like the `hRawBody' but decodes it as UTF-8 to a `String'. + +hBodyStringUTF8 :: BodyM dir m => dir -> m String +hBodyStringUTF8 d = U.toString <$> body d + +-- | Like `hBodyStringUTF8' but specifically for `Http' `Request's. + +hRequestBodyStringUTF8 :: BodyM Request m => m String +hRequestBodyStringUTF8 = hBodyStringUTF8 forRequest + +-- | Like `hBodyStringUTF8' but specifically for `Http' `Response's. + +hResponseBodyStringUTF8 :: BodyM Response m => m String +hResponseBodyStringUTF8 = hBodyStringUTF8 forResponse + +{- | +Try to parse the message body, as a result of `hBodyText', as URI encoded `POST` +parameters. Returns as a URI `Parameter' type or nothing when parsing fails. +-} + +hParameters :: (BodyM d m, HttpM d m) => d -> String -> m Parameters +hParameters d def = fw params . unpack <$> hBodyText d def + +-- | Like `hParameters' but specifically for `HTTP' `Request's. + +hRequestParameters :: (BodyM Request m, HttpM Request m) => String -> m Parameters +hRequestParameters = hParameters forRequest + +-- | Like `hParameters' but specifically for `HTTP' `Response's. + +hResponseParameters :: (BodyM Response m, HttpM Response m) => String -> m Parameters +hResponseParameters = hParameters forResponse + diff --git a/src/Network/Salvia/Handler/CGI.hs b/src/Network/Salvia/Handler/CGI.hs --- a/src/Network/Salvia/Handler/CGI.hs +++ b/src/Network/Salvia/Handler/CGI.hs @@ -1,22 +1,90 @@ +{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.CGI (hCGI) where +import Control.Applicative +import Control.Category +import Control.Concurrent import Control.Monad.State +import Data.Char +import Data.List +import Data.List.Split import Data.Record.Label -import Network.Protocol.Http -import Network.Salvia.Httpd +import Network.Protocol.Http hiding (server) +import Network.Protocol.Uri hiding (host) +import Network.Salvia.Interface +import Network.Salvia.Handler.Error +import Network.Salvia.Handler.Parser +import Network.Socket +import Prelude hiding ((.), id) import System.IO -import System.Process (runProcess, waitForProcess) +import System.Process +import qualified Data.ByteString.Lazy as B -{- | -Handle CGI scripts, not yet working properly. --} +-- | Handler to run CGI scripts. -hCGI :: ResourceHandler () -hCGI name = do - setM (status % response) OK - h <- getM sock - lift $ do - p <- runProcess name [] Nothing Nothing (Just h) (Just h) (Just stderr) - waitForProcess p - return () +-- todo: fails on ipv6 en unix sockets. +-- todo: stderr? + +hCGI :: (MonadIO m, HttpM' m, BodyM Request m, SendM m, HandleQueueM m, ServerM m, AddressM' m) => FilePath -> m () +hCGI fn = + do adm <- admin + hst <- host + (cp, ca) <- clientAddress >>= addr + (sp, sa) <- serverAddress >>= addr + hdrs <- request (getM headers) + _query <- request (getM (query . asUri)) + _path <- request (getM (path . asUri)) + _method <- request (getM method) + + -- Helper function to convert all headers to environment variables. + let headerDecls = + map (\(a, b) -> ("HTTP_" ++ (map toUpper . intercalate "_" . splitOn "-") a, b)) + . unHeaders + + -- Set the of expoerted server knowledge. + let envs = + ("GATEWAY_INTERFACE", "CGI/1.1") + : ("REQUEST_METHOD", show _method) + : ("REQUEST_URI", _path) + : ("QUERY_STRING", _query) + : ("SERVER_SOFTWARE", "Salvia") + : ("SERVER_SIGNATURE", "") + : ("SERVER_PROTOCOL", "HTTP/1.1") + : ("SERVER_ADMIN", adm) + : ("SERVER_NAME", hst) + : ("SERVER_ADDR", sa) + : ("SERVER_PORT", show sp) + : ("REMOTE_ADDR", ca) + : ("REMOTE_PORT", show cp) + : ("SCRIPT_FILENAME", fn) + : ("SCRIPT_NAME", fn) + : headerDecls hdrs + + -- Start up the CGI script with the appropriate environment variables. + -- todo: what to do with stderr? log? + (inp, out, _, pid) <- liftIO (runInteractiveProcess fn [] Nothing $ Just envs) + + -- Read the request body and fork a thread to spool the body to the CGI + -- script's input. After spooling, or when there is no data, the scripts + -- input will be closed. + b <- body forRequest + liftIO $ forkIO (B.hPut inp b >> hClose inp) >> return () + + -- Read the headers produced by the CGI script and store them as the + -- response headers of this handler. + hs <- liftIO (readNonEmptyLines out) + case parseHeaders hs of + Left e -> hCustomError InternalServerError e + Right r -> response (headers =: r) + + -- Spool all data from the CGI script's output to the client. When + -- finished, close the handle and wait for the script to terminate. + spool out + enqueueHandle (const (hClose out <* waitForProcess pid)) + + where + addr (SockAddrInet p a) = (,) p <$> liftIO (inet_ntoa a) + addr (SockAddrInet6 p _ _ _) = return (p, "ipv6") + addr _ = return (-1, "unix") + diff --git a/src/Network/Salvia/Handler/Close.hs b/src/Network/Salvia/Handler/Close.hs --- a/src/Network/Salvia/Handler/Close.hs +++ b/src/Network/Salvia/Handler/Close.hs @@ -1,21 +1,22 @@ -module Network.Salvia.Handler.Close ( - hCloseConn +module Network.Salvia.Handler.Close + ( hCloseConn , hKeepAlive - ) where + , emptyQueue + ) +where import Control.Monad.State import Data.Maybe import Data.Record.Label import Network.Protocol.Http -import Network.Salvia.Httpd +import Network.Salvia.Interface +import Network.Salvia.Handler.Error import System.IO -{- | -Run a handler once and close the connection afterwards. --} +-- | Run a handler once and close the connection afterwards. -hCloseConn :: Handler () -> Handler () -hCloseConn h = h >> getM sock >>= liftIO . hClose +hCloseConn :: (HandleM m, MonadIO m) => m a -> m () +hCloseConn h = h >> handle >>= flip catchIO () . hClose {- | Run a handler and keep the connection open for potential consecutive requests. @@ -28,24 +29,34 @@ * The client has set the `connection` header field to 'close'. * The connection has already been closed, possible due to IO errors. + +* The HTTP version is HTTP/1.0. -} -hKeepAlive :: Handler () -> Handler () +hKeepAlive :: (QueueM m, HandleM m, HttpM' m, MonadIO m) => m a -> m () hKeepAlive handler = - do handler - - h <- getM sock - conn <- getM (connection % request) - len <- getM (contentLength % response) + do _ <- handler + h <- handle + conn <- request (getM connection) + ver <- request (getM version) + len <- response (getM contentLength) closed <- liftIO (hIsClosed h) - - if or [closed, conn == "Close", isNothing (len::Maybe Integer) ] - then liftIO (hClose h) - else resetContext >> hKeepAlive handler + if or [ closed + , conn == Just "Close" + , isNothing (len :: Maybe Integer) + , ver == http10 + ] + then catchIO (hClose h) () + else resetContext >> hKeepAlive handler -resetContext :: Handler () +resetContext :: (HttpM' m, QueueM m) => m () resetContext = - do setM request emptyRequest - setM response emptyResponse - setM queue [] + do request (put emptyRequest) + response (put emptyResponse) + emptyQueue + +-- | Empty the send queue. + +emptyQueue :: QueueM m => m () +emptyQueue = dequeue >>= return () `maybe` const emptyQueue diff --git a/src/Network/Salvia/Handler/Cookie.hs b/src/Network/Salvia/Handler/Cookie.hs --- a/src/Network/Salvia/Handler/Cookie.hs +++ b/src/Network/Salvia/Handler/Cookie.hs @@ -1,44 +1,55 @@ -module Network.Salvia.Handler.Cookie ( - hSetCookies - , hGetCookies - - , newCookie - ) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Cookie where import Control.Applicative hiding (empty) -import Control.Monad.State +import Control.Category import Data.Record.Label import Data.Time.Format -import Data.Time.LocalTime -import Network.Protocol.Cookie (showCookies, Cookie, Cookies, parseCookies, empty, path, port, expires) -import Network.Protocol.Http (cookie) -import Network.Salvia.Httpd -import System.Locale (defaultTimeLocale) +import Network.Protocol.Cookie +import Network.Salvia.Interface +import Network.Socket +import Prelude hiding ((.), id) +import System.Locale +import qualified Network.Protocol.Http as H -{- | Set the `cookie` HTTP response header (Set-Cookie) with the specified `Cookies`. -} +{- | Set the `Set-Cookie` HTTP response header with the specified `Cookies`. -} -hSetCookies :: Cookies -> Handler () -hSetCookies = setM (cookie % response) . showCookies +hSetCookie :: HttpM H.Response m => Cookies -> m () +hSetCookie = response . setM H.setCookie . Just . show {- | Try to get the cookies from the HTTP `cookie` request header. -} -hGetCookies :: Handler (Maybe Cookies) -hGetCookies = parseCookies <$> getM (cookie % request) +hCookie :: (HttpM H.Request m) => m (Maybe Cookies) +hCookie = fmap (fw cookies) <$> request (getM H.cookie) +{- | Delete one cookie by removing it from the `Set-Cookie' header. -} + +hDelCookie :: HttpM H.Response m => String -> m () +hDelCookie nm = response (theCookie =: Just Nothing) + where theCookie = fmapL (pickCookie nm) + . fmapL (cookies `iso` id) + . H.setCookie + {- | Convenient method for creating cookies that expire in the near future and are bound to the domain and port this server runs on. The path will be locked to -root. +root. If the second argument is set, the cookie will be valid for all +subdomains. -} -newCookie :: LocalTime -> Handler Cookie -newCookie expire = do - httpd <- getM config - return $ empty { - path = Just "/" --- , domain = Just $ '.' : hostname httpd - , port = [fromEnum $ listenPort httpd] - , expires = Just $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire - } - +hNewCookie :: (ServerM m, ServerAddressM m, FormatTime t) => t -> Bool -> m Cookie +hNewCookie expire _ = do +-- hst <- host + sAddr <- serverAddress + return + . (path `set` Just "/") +-- No domain for now, to make demoing easier. The below line doesn't +-- work in Chrome and Webkit if hst is an IP. +-- . (domain `set` Just ((if wildcard then ('.':) else id) hst)) + . (port `set` [portNum sAddr]) + . (expires `set` Just ("\"" ++ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %Z" expire ++ "\"")) + $ empty + where portNum (SockAddrInet p _) = fromIntegral p + portNum (SockAddrInet6 p _ _ _) = fromIntegral p + portNum _ = -1 diff --git a/src/Network/Salvia/Handler/Counter.hs b/src/Network/Salvia/Handler/Counter.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/Counter.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Network.Salvia.Handler.Counter (hCounter) where - -import Control.Concurrent.STM -import Control.Monad.State -import Network.Salvia.Httpd - -{- | This handler simply increases the request counter variable. -} - -hCounter :: TVar Int -> Handler () -hCounter c = lift $ atomically $ readTVar c >>= writeTVar c . (+1) - diff --git a/src/Network/Salvia/Handler/Directory.hs b/src/Network/Salvia/Handler/Directory.hs --- a/src/Network/Salvia/Handler/Directory.hs +++ b/src/Network/Salvia/Handler/Directory.hs @@ -1,17 +1,21 @@ -module Network.Salvia.Handler.Directory ( - hDirectory +{- | Rendering of HTML directory listings. -} +module Network.Salvia.Handler.Directory + ( hDirectory , hDirectoryResource - ) where + ) +where -import Control.Monad.State +import Control.Applicative +import Control.Category +import Control.Monad.State hiding (get) import Data.List (sort) import Data.Record.Label -import Misc.Misc (bool) import Network.Protocol.Http import Network.Protocol.Uri (path) +import Network.Salvia.Interface import Network.Salvia.Handler.File (hResource) import Network.Salvia.Handler.Redirect -import Network.Salvia.Httpd +import Prelude hiding ((.), id, mod) import System.Directory (doesDirectoryExist, getDirectoryContents) {- | @@ -19,35 +23,42 @@ filesystem. -} -hDirectoryResource :: ResourceHandler () -hDirectoryResource dirName = do - (u, p) <- bothM (uri % request) (getM path) - if (null p) || last p /= '/' - then hRedirect (lmod path (++"/") u) - else dirHandler dirName +hDirectoryResource + :: (MonadIO m, HttpM' m, SendM m) + => FilePath -- ^ Directory to produce a listing for. + -> m () +hDirectoryResource dirName = + do u <- request (getM asUri) + let p = get path u + if (null p) || last p /= '/' + then hRedirect (show $ mod path (++"/") u) + else dirHandler dirName {- | -Like `hDirectoryResource` but uses the path of the current request URI. +Like `hDirectoryResource` but uses the path from the current request URI. -} -hDirectory :: Handler () +hDirectory :: (MonadIO m, HttpM' m, SendM m) => m () hDirectory = hResource hDirectoryResource -dirHandler:: ResourceHandler () -dirHandler dirName = do - p <- getM (path % uri % request) - filenames <- lift $ getDirectoryContents dirName - processed <- lift $ mapM (processFilename dirName) (sort filenames) - let b = listing p processed - enterM response $ do - setM contentType ("text/html", Nothing) - setM contentLength (Just $ length b) - setM status OK - sendStr b +-- Helper function that does all the work. +dirHandler :: (MonadIO m, HttpM' m, SendM m) => FilePath -> m () +dirHandler dirName = + do p <- request (getM (path . asUri)) + filenames <- liftIO $ getDirectoryContents dirName + processed <- liftIO $ mapM (processFilename dirName) (sort filenames) + let b = listing p processed + response $ + do contentType =: Just ("text/html", Nothing) + contentLength =: Just (length b) + status =: OK + send b + -- Add trailing slash to a directory name. processFilename :: FilePath -> FilePath -> IO FilePath -processFilename d f = bool (f ++ "/") f `liftM` doesDirectoryExist (d ++ f) +processFilename d f = + (\b -> (if b then (++"/") else id) f) <$> doesDirectoryExist (d ++ f) -- Turn a list of filenames into HTML directory listing. listing :: FilePath -> [FilePath] -> String diff --git a/src/Network/Salvia/Handler/Dispatching.hs b/src/Network/Salvia/Handler/Dispatching.hs --- a/src/Network/Salvia/Handler/Dispatching.hs +++ b/src/Network/Salvia/Handler/Dispatching.hs @@ -1,12 +1,10 @@ -module Network.Salvia.Handler.Dispatching ( - Dispatcher - , ListDispatcher - , hDispatch - , hListDispatch - ) where +{-# LANGUAGE RankNTypes, TypeOperators, FlexibleContexts, ScopedTypeVariables #-} +module Network.Salvia.Handler.Dispatching where +import Control.Monad.State import Data.Record.Label -import Network.Salvia.Httpd +import Network.Protocol.Http +import Network.Salvia.Interface {- | The dispatcher type takes one value to dispatch on and two handlers. The first @@ -15,14 +13,14 @@ `False`. -} -type Dispatcher a b = a -> Handler b -> Handler b -> Handler b +type Dispatcher a m b = a -> m b -> m b -> m b {- | -A list dispatcher takes a mapping from dispatch values and handlers and one -default handler. +A list dispatcher takes a mapping from dispatch values to handlers and one +default fallback handler. -} -type ListDispatcher a b = [(a, Handler b)] -> Handler b -> Handler b +type ListDispatcher a m b = [(a, m b)] -> m b -> m b {- | Dispatch on an arbitrary part of the context using an arbitrary predicate. When @@ -30,12 +28,14 @@ handler will be invoked, otherwise the second handler will be used. -} -hDispatch :: (Show a, Show c) => Label Context c -> (a -> c -> Bool) -> Dispatcher a b -hDispatch f match a handler _default = do - ctx <- getM f - if a `match` ctx - then handler - else _default +hDispatch + :: forall a b c d m. HttpM d m => d -> (Http d :-> b) -> (c -> b -> Bool) -> Dispatcher c m a +hDispatch _ f match a handler _default = + do let h = http :: State (Http d) b -> m b + ctx <- h (getM f) + if a `match` ctx + then handler + else _default {- | Turns a dispatcher function into a list dispatcher. This enables handler @@ -43,6 +43,22 @@ in the `ListDispatcher` type hold the default handler will be invoked. -} -hListDispatch :: Dispatcher a b -> ListDispatcher a b -hListDispatch disp = flip $ foldr $ uncurry disp +hListDispatch :: Dispatcher a m b -> ListDispatcher a m b +hListDispatch disp = flip $ foldr (uncurry disp) + +{- | +Like the `hDispatch` but always dispatches on a (part of) the `HTTP +Request' part of the context. +-} + +hRequestDispatch :: HttpM Request m => (Http Request :-> b) -> (t -> b -> Bool) -> Dispatcher t m c +hRequestDispatch = hDispatch forRequest + +{- | +Like the `hDispatch` but always dispatches on a (part of) the `HTTP +Response' part of the context. +-} + +hResponseDispatch :: HttpM Response m => (Http Response :-> b) -> (t -> b -> Bool) -> Dispatcher t m c +hResponseDispatch = hDispatch forResponse diff --git a/src/Network/Salvia/Handler/Environment.hs b/src/Network/Salvia/Handler/Environment.hs --- a/src/Network/Salvia/Handler/Environment.hs +++ b/src/Network/Salvia/Handler/Environment.hs @@ -1,78 +1,50 @@ -module Network.Salvia.Handler.Environment ( - hDefaultEnv - , hSessionEnv - ) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Environment +( hDefaultEnv +, hEnvNoKeepAlive +) +where -import Control.Concurrent.STM +import Control.Monad.State import Network.Protocol.Http +import Network.Salvia.Interface import Network.Salvia.Handler.Banner -import Network.Salvia.Handler.Counter import Network.Salvia.Handler.Close import Network.Salvia.Handler.Error import Network.Salvia.Handler.Head -import Network.Salvia.Handler.Log import Network.Salvia.Handler.Parser import Network.Salvia.Handler.Printer -import Network.Salvia.Handler.Session -import Network.Salvia.Httpd -import System.IO +import Prelude hiding (log) {- | -This is the default stateless handler evnironment. It takes care of request -parsing (`hParser`), response printing (`hPrinter`), request logging (`hLog`), -connection keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and -printing the `salvia-httpd` server banner (`hBanner`). +This is the default handler environment. It takes care of request parsing +(`hRequestParser`), response printing (`hResponsePrinter`), connection +keep-alives (`hKeepAlive`), handling `HEAD` requests (`hHead`) and printing the +`salvia-httpd` server banner (`hBanner`). -} hDefaultEnv - :: Handler () -- ^ Handler to run in the default environment. - -> Handler () + :: (MonadIO m, HandleM m, RawHttpM' m, HttpM' m, QueueM m, SendM m, FlushM Response m) + => m () -- ^ Handler to run in the default environment. + -> m () hDefaultEnv handler = hKeepAlive $ - hParser (1000 * 15) - (wrapper Nothing . parseError) - (wrapper Nothing $ hHead handler) - -{- | -This function is a more advanced version of the `hDefaultEnv` handler -environment that takes a global state into account. It takes a shared variable -containg the connection counter (used by `hCounter`) and a variable containing -all session information (used by `hSession`). Handlers that run in this -environment take should be parametrized with a session. --} - -hSessionEnv - :: TVar Int -- ^ Request count variable. - -> Sessions a -- ^ Session collection variable. - -> SessionHandler a () -- ^ Handler parametrized with current session. - -> Handler () -hSessionEnv count sessions handler = - hKeepAlive $ - hParser (1000 * 15) - (wrapper (Just count) . parseError) - (wrapper (Just count) $ - do session <- hSession sessions 300 - hHead (handler session)) - --- Helper functions. - -before :: Handler () -before = hBanner "salvia-httpd" - -after :: Maybe (TVar Int) -> Handler () -after mc = - do hPrinter - maybe - (hLog stdout) - (\c -> hCounter c >> hLogWithCounter c stdout) - mc + do hBanner "salvia-httpd" + _ <- hRequestParser (1000 * 4) + (hCustomError BadRequest) + (hHead handler) + hResponsePrinter -wrapper :: Maybe (TVar Int) -> Handler a -> Handler () -wrapper c h = before >> h >> after c +-- | Like `hDefaultEnv' but only serves one request per connection. -parseError :: String -> Handler () -parseError err = - do hError BadRequest - sendStrLn [] - sendStrLn err +hEnvNoKeepAlive + :: (MonadIO m, HandleM m, RawHttpM' m, HttpM' m, QueueM m, SendM m, FlushM Response m) + => m () -- ^ Handler to run in this environment. + -> m () +hEnvNoKeepAlive handler = + do hBanner "salvia-httpd" + _ <- hRequestParser (1000 * 4) + (hCustomError BadRequest) + (hHead handler) + hResponsePrinter diff --git a/src/Network/Salvia/Handler/Error.hs b/src/Network/Salvia/Handler/Error.hs --- a/src/Network/Salvia/Handler/Error.hs +++ b/src/Network/Salvia/Handler/Error.hs @@ -1,34 +1,35 @@ -module Network.Salvia.Handler.Error ( - hError - , hCustomError - , hIOError - , safeIO - ) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Error +( hError +, hCustomError +, hIOError +, hSafeIO +, catchIO +) +where -import Control.Monad.State +import Control.Monad.Trans import Data.Record.Label import Network.Protocol.Http -import Network.Salvia.Httpd +import Network.Salvia.Interface import System.IO.Error -{- | -The 'hError' handler enables the creation of a default style of error responses -for the specified HTTP `Status` code. --} +-- | The 'hError' handler enables the creation of a default style of error +-- responses for the specified HTTP `Status` code. -hError :: Status -> Handler () +hError :: (HttpM Response m, SendM m) => Status -> m () hError e = hCustomError e (concat ["[", show (codeFromStatus e), "] ", show e, "\n"]) -{- | Like `hError` but with a custom error message. -} +-- | Like `hError` but with a custom error message. -hCustomError :: Status -> String -> Handler () -hCustomError e m = do - enterM response $ do - setM status e - setM contentLength (Just $ length m) - setM contentType ("text/plain", Nothing) - sendStr m +hCustomError :: (HttpM Response m, SendM m) => Status -> String -> m () +hCustomError e m = + do response $ + do status =: e + contentLength =: Just (length m) + contentType =: Just ("text/plain", Nothing) + send m {- | Map an `IOError` to a default style error response. @@ -41,18 +42,23 @@ > | True = hError InternalServerError -} -hIOError :: IOError -> Handler () +hIOError :: (HttpM Response m, SendM m) => IOError -> m () hIOError e | isDoesNotExistError e = hError NotFound | isAlreadyInUseError e = hError ServiceUnavailable | isPermissionError e = hError Forbidden - | True = hError InternalServerError + | otherwise = hError InternalServerError -{- | -Execute an handler with the result of an IO action. When the IO actions fails a -default error handler will be executed. --} +-- | Execute an handler with the result of an IO action. When the IO actions +-- fails a default error handler will be executed. -safeIO :: IO a -> (a -> Handler ()) -> Handler () -safeIO io h = lift (try io) >>= either hIOError h +hSafeIO + :: (MonadIO m, HttpM Response m, SendM m) + => IO a -> (a -> m ()) -> m () +hSafeIO io h = liftIO (try io) >>= either hIOError h + +-- | Utility function to easily catch IO errors. + +catchIO :: MonadIO m => IO a -> a -> m a +catchIO a b = liftIO (a `catch` (const (return b))) diff --git a/src/Network/Salvia/Handler/Extension.hs b/src/Network/Salvia/Handler/Extension.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Handler/Extension.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Extension + ( hExtension + , hExtensionRouter + ) +where + +import Control.Category +import Network.Protocol.Http +import Network.Protocol.Uri +import Network.Salvia.Handler.Dispatching +import Network.Salvia.Interface +import Prelude hiding ((.), id) + +{- | Request dispatcher based on the request path file extenstion. -} + +hExtension :: HttpM Request m => Dispatcher (Maybe String) m a +hExtension = hRequestDispatch (extension . path . asUri) (==) + +{- | List dispatcher version of `hExtension`. -} + +hExtensionRouter :: HttpM Request m => ListDispatcher (Maybe String) m a +hExtensionRouter = hListDispatch hExtension + diff --git a/src/Network/Salvia/Handler/ExtensionDispatcher.hs b/src/Network/Salvia/Handler/ExtensionDispatcher.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/ExtensionDispatcher.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Network.Salvia.Handler.ExtensionDispatcher ( - hExtension - , hExtensionRouter - ) where - -import Data.Record.Label -import Network.Protocol.Http (uri) -import Network.Protocol.Uri (extension, path) -import Network.Salvia.Handler.Dispatching -import Network.Salvia.Httpd (request) - -{- | Request dispatcher based on the request path file extenstion. -} - -hExtension :: Dispatcher (Maybe String) a -hExtension = hDispatch (extension % path % uri % request) (==) - -{- | List dispatcher version of `hExtension`. -} - -hExtensionRouter :: ListDispatcher (Maybe String) a -hExtensionRouter = hListDispatch hExtension - diff --git a/src/Network/Salvia/Handler/Fallback.hs b/src/Network/Salvia/Handler/Fallback.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/Fallback.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Network.Salvia.Handler.Fallback (hOr, hEither) where - -import Control.Applicative -import Control.Monad.State -import Data.Record.Label -import Network.Protocol.Http -import Network.Salvia.Httpd - -{- | -Until I figure out how to do this correctly, this handler somewow implements -the MonadPlus/Alternative instance using a custom function. - -When the first handler fails the response will be reset and the second handler -is executed. Failure is indicated by an HTTP response `Status` bigger than or -equal to 400 (`BadRequest`). See `statusFailure`. --} - -hOr :: Handler a -> Handler a -> Handler a -hOr h0 h1 = do - a <- h0 - st <- getM (status % response) - if statusFailure st - then reset >> h1 - else return a - -{- | -Like the `hOr` function, but the types of the alternatives may differ because -the values are packed up in an `Either`. --} - -hEither :: Handler a -> Handler b -> Handler (Either a b) -hEither h0 h1 = (Left <$> h0) `hOr` (Right <$> h1) - diff --git a/src/Network/Salvia/Handler/File.hs b/src/Network/Salvia/Handler/File.hs --- a/src/Network/Salvia/Handler/File.hs +++ b/src/Network/Salvia/Handler/File.hs @@ -1,88 +1,123 @@ -module Network.Salvia.Handler.File ( - hFile - , hFileResource - - , hFileFilter - , hFileResourceFilter - - , hResource - , hUri - ) where +{-# LANGUAGE FlexibleContexts, TypeOperators #-} +module Network.Salvia.Handler.File +( hFile +, hFileResource +, fileMime +, hFileFilter +, hFileResourceFilter +, hResource +, hUri +) +where -import Control.Monad.State +import Control.Applicative +import Control.Category +import Control.Monad.State hiding (get) +import Data.ByteString.Lazy.UTF8 (fromString) +import Data.Digest.Pure.MD5 +import Data.Maybe import Data.Record.Label +import Data.Time +import Data.Time.Clock.POSIX import Network.Protocol.Http import Network.Protocol.Mime -import Network.Protocol.Uri (mimetype, path, parseURI) +import Network.Protocol.Uri import Network.Salvia.Handler.Error -import Network.Salvia.Httpd +import Network.Salvia.Handler.Range +import Network.Salvia.Interface +import Prelude hiding ((.), id) import System.IO +import System.Locale +import System.Posix.Files +import qualified Data.ByteString.Lazy as B {- | Serve a file from the filesystem indicated by the specified filepath. When -there is some kind of `IOError` the `safeIO` function will be used to produce a +there is some kind of `IOError` the `hSafeIO` function will be used to produce a corresponding error response. The `contentType` will be the mime-type based on the filename extension using the `mimetype` function. The `contentLength` will be set the file's size. -} --- TODO: what to do with encoding? -hFileResource :: ResourceHandler () -hFileResource file = do - let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path) - safeIO (openBinaryFile file ReadMode) - $ \fd -> do - fs <- lift $ hFileSize fd - enterM response $ do - setM contentType (m, Just "utf-8") - setM contentLength (Just fs) - setM status OK - spoolBs id fd +hFileResource :: (MonadIO m, HttpM' m, SendM m) => FilePath -> m () +hFileResource file = + hSafeIO (openBinaryFile file ReadMode) $ \fd -> + do fs <- liftIO (hFileSize fd) + rng <- request (getM range) + mt <- liftIO $ + formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S %z" + . posixSecondsToUTCTime + . realToFrac + . modificationTime <$> getFileStatus file + let etag = show . md5 $ fromString mt + response $ + do contentType =: Just (fileMime file, Nothing) + contentLength =: Just fs + lastModified =: Just mt + eTag =: Just etag + acceptRanges =: Just "bytes" + status =: OK + + case rng of + -- todo: use peek and cleanup this range code. + Just (Range (Just from) to _) -> + do let t = fromMaybe (fs - 1) to + r = Range (Just from) (Just t) (Just fs) + response $ + do status =: PartialContent + contentRange =: Just r + contentLength =: Just (t - from + 1) + let chop = maybe id (B.take . fromIntegral . (subtract from)) to + spoolWithBs (chop . B.drop (fromIntegral from)) fd + return () + + _ -> spoolWithBs id fd + +fileMime :: FilePath -> Mime +fileMime file = + maybe defaultMime id + $ (either (const Nothing) Just (parseUri file) + >>= mimetype . get path) + {- | Like the `hFileResource` handler, but with a custom filter over the content. -This function will assume the content is an UTF-8 encoded text file. No -`contentLength` header will be set using this handler. +This function will assume the content is an UTF-8 encoded text file. Because of +the possibly unpredictable behavior of the filter, no `contentLength` header +will be set using this handler. -} --- TODO: what to do with encoding? -hFileResourceFilter :: (String -> String) -> ResourceHandler () -hFileResourceFilter fFilter file = do -- TODO... this should be a more general hFilter - let m = maybe defaultMime id $ (parseURI file >>= mimetype . lget path) - safeIO (openBinaryFile file ReadMode) - $ \fd -> do - enterM response $ do - setM contentType (m, Just "utf-8") - setM status OK - spool fFilter fd +hFileResourceFilter :: (MonadIO m, HttpM Response m, SendM m) => (String -> String) -> FilePath -> m () +hFileResourceFilter f file = + hSafeIO (openFile file ReadMode) $ \fd -> + do response $ + do contentType =: Just (fileMime file, Just "utf-8") + status =: OK + spoolWith f fd {- | -Turn a resource handler into a regular handler that utilizes the path part of -the request URI as the resource identifier. +Turn a handler that is parametrized by a file resources into a regular handler +that utilizes the path part of the request URI as the resource identifier. -} -hResource :: ResourceHandler a -> Handler a -hResource rh = getM (path % uri % request) >>= rh +hResource :: HttpM Request m => (FilePath -> m a) -> m a +hResource rh = request (getM (path . asUri)) >>= rh {- | -Turn a URI handler into a regular handler that utilizes the request URI as the -resource identifier. +Turn a handler that is parametrized by a URI into a regular handler that +utilizes the request URI as the resource identifier. -} -hUri :: UriHandler a -> Handler a -hUri rh = getM (uri % request) >>= rh +hUri :: HttpM Request m => (Uri -> m a) -> m a +hUri rh = request (getM asUri) >>= rh -{- | -Like `hFileResource` but uses the path of the current request URI. --} +-- | Like `hFileResource` but uses the path of the current request URI. -hFile :: Handler () +hFile :: (MonadIO m, HttpM' m, SendM m) => m () hFile = hResource hFileResource -{- | -Like `hFileResourceFilter` but uses the path of the current request URI. --} +-- | Like `hFileResourceFilter` but uses the path of the current request URI. -hFileFilter :: (String -> String) -> Handler () +hFileFilter :: (MonadIO m, HttpM' m, SendM m) => (String -> String) -> m () hFileFilter = hResource . hFileResourceFilter diff --git a/src/Network/Salvia/Handler/FileSystem.hs b/src/Network/Salvia/Handler/FileSystem.hs --- a/src/Network/Salvia/Handler/FileSystem.hs +++ b/src/Network/Salvia/Handler/FileSystem.hs @@ -1,19 +1,22 @@ -module Network.Salvia.Handler.FileSystem ( - hFileSystem - , hFileSystemNoIndexes - , hFileTypeDispatcher - ) where +{- | Serving parts of the local file system. -} +module Network.Salvia.Handler.FileSystem +( hFileSystem +, hFileSystemNoIndexes +, hFileTypeDispatcher +) +where +import Control.Category import Control.Monad.State import Data.Record.Label -import Misc.Misc (bool) import Network.Protocol.Http -import Network.Protocol.Uri (jail, path) +import Network.Protocol.Uri +import Network.Salvia.Interface import Network.Salvia.Handler.Directory import Network.Salvia.Handler.Error import Network.Salvia.Handler.File -import Network.Salvia.Httpd -import System.Directory (doesDirectoryExist) +import Prelude hiding ((.), id) +import System.Directory {- | Dispatch based on file type; regular files or directories. The first handler @@ -25,17 +28,25 @@ parts of the file system. -} -hFileTypeDispatcher :: ResourceHandler () -> ResourceHandler () -> ResourceHandler () +hFileTypeDispatcher + :: (MonadIO m, HttpM' m, SendM m) + => (FilePath -> m ()) -- ^ Handler to invoke in case of directory. + -> (FilePath -> m ()) -- ^ Handler to invoke in case of regular files. + -> FilePath -- ^ Directory to serve. + -> m () hFileTypeDispatcher hdir hfile dir = - getM (path % uri % request) >>= - hJailedDispatch dir hdir hfile . (dir ++) + do p <- request $ getM (path . asUri) + hJailedDispatch dir hdir hfile (dir /+ p) {- | Serve single directory by combining the `hDirectoryResource` and `hFileResource` handlers in the `hFileTypeDispatcher`. -} -hFileSystem :: ResourceHandler () +hFileSystem + :: (MonadIO m, HttpM' m, SendM m) + => FilePath -- ^ Directory to serve. + -> m () hFileSystem = hFileTypeDispatcher hDirectoryResource hFileResource {- | @@ -43,14 +54,21 @@ Instead of an directory index an `Forbidden` response will be created. -} --- Show file contents, do not show directory indexes. -hFileSystemNoIndexes :: ResourceHandler () +hFileSystemNoIndexes + :: (MonadIO m, HttpM' m, SendM m) + => FilePath -- ^ Directory to serve. + -> m () hFileSystemNoIndexes = hFileTypeDispatcher (const $ hError Forbidden) hFileResource -hJailedDispatch :: FilePath -> ResourceHandler () -> ResourceHandler () -> ResourceHandler () -hJailedDispatch dir hdir hfile file = do - case jail dir file of - Nothing -> hError Forbidden - Just f -> bool (hdir file) (hfile file) - =<< lift (doesDirectoryExist f) +-- Helper distpatcher that takes care of jailing the request in the specified +-- file system directory. + +hJailedDispatch + :: (MonadIO m, HttpM' m, SendM m) + => FilePath -> (FilePath -> m ()) -> (FilePath -> m ()) -> FilePath -> m () +hJailedDispatch dir hdir hfile file = + do case jail dir file of + Nothing -> hError Forbidden + Just f -> (\b -> (if b then hdir else hfile) file) + =<< liftIO (doesDirectoryExist f) diff --git a/src/Network/Salvia/Handler/Head.hs b/src/Network/Salvia/Handler/Head.hs --- a/src/Network/Salvia/Handler/Head.hs +++ b/src/Network/Salvia/Handler/Head.hs @@ -1,23 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.Head (hHead) where -import Control.Applicative -import Control.Monad.State (put) +import Control.Monad.Trans +import Control.Applicative hiding (empty) import Data.Record.Label import Network.Protocol.Http -import Network.Salvia.Httpd +import Network.Salvia.Handler.Rewrite +import Network.Salvia.Handler.Close +import Network.Salvia.Interface {- | -The 'hHead' handler makes sure no response body is sent to the client when the -request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the +The 'hHead' handler makes sure no `HTTP' `Response' body is sent to the client +when the request is an HTTP 'HEAD' request. In the case of a 'HEAD' request the specified sub handler will be executed under the assumption that the request was a 'GET' request, otherwise this handler will act as the identify function. -} -hHead :: Handler a -> Handler a -hHead handler = do - m <- getM (method % request) - case m of - HEAD -> withM (method % request) (put GET) $ - handler <* emptyQueue - _ -> handler +hHead :: (MonadIO m, QueueM m, HttpM Request m) => m a -> m a +hHead handler = + do m <- request (getM method) + case m of + HEAD -> hLocalRequest method (const GET) $ + handler <* emptyQueue + _ -> handler diff --git a/src/Network/Salvia/Handler/Log.hs b/src/Network/Salvia/Handler/Log.hs --- a/src/Network/Salvia/Handler/Log.hs +++ b/src/Network/Salvia/Handler/Log.hs @@ -1,47 +1,53 @@ -module Network.Salvia.Handler.Log ( - hLog - , hLogWithCounter - ) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Log where -import Control.Concurrent.STM +import Control.Applicative import Control.Monad.State -import Data.Record.Label -import Misc.Terminal (red, green, reset) +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.Httpd (Handler, request, response, address) +import Network.Salvia.Interface import System.IO +import System.Locale {- | -A simple logger that prints a summery of the request information to the -specified file handle. +A simple logger that prints a summery of the request information to +the specified file handle. -} -hLog :: Handle -> Handler () -hLog = logger Nothing +hLog :: (AddressM' m , MonadIO m, HttpM' m) => Handle -> m () +hLog h = + do 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 + let code = codeFromStatus st + liftIO + . hPutStrLn h + $ intercalate " ; " + [ dt + , show sa + , show mt + , show ca + , ur + , show code ++ " " ++ show st + ] -{- | Like `hLog` but also prints the request count since server startup. -} +-- | Dump the request headers to the standard output, useful for debugging. -hLogWithCounter :: TVar Int -> Handle -> Handler () -hLogWithCounter a = logger (Just a) +hDumpRequest :: (HttpM Request m, MonadIO m) => m () +hDumpRequest = request get >>= liftIO . print -logger :: Maybe (TVar Int) -> Handle -> Handler () -logger count handle = do - c <- case count of - Nothing -> return "" - Just c' -> liftIO (show `liftM` atomically (readTVar c')) - mt <- getM (method % request) - ur <- getM (uri % request) - st <- getM (status % response) - addr <- getM address - let code = codeFromStatus st - clr = if code >= 400 then red else green - liftIO $ hPutStrLn handle $ concat [ - concat ["[", show addr, "] ", c, "\t"] - , show mt, "\t" - , show ur, " -> " - , clr - , show code, " " - , show st - , reset - ] +-- | Dump the response headers to the standard output, useful for debugging. + +hDumpResponse :: (HttpM Response m, MonadIO m) => m () +hDumpResponse = response get >>= liftIO . print diff --git a/src/Network/Salvia/Handler/Login.hs b/src/Network/Salvia/Handler/Login.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/Login.hs +++ /dev/null @@ -1,276 +0,0 @@ -module Network.Salvia.Handler.Login ( - - -- * Basic types. - Username - , Password - , Action - , Actions - , User (..) - , Users - , UserDatabase - , TUserDatabase - - -- * User Sessions. - , UserPayload (..) - , UserSession - , TUserSession - , UserSessionHandler - - -- * Handlers. - , hSignup - , hLogin - , hLogout - , hLoginfo - - , hAuthorized - , hAuthorizedUser - - -- * Helper functions. - , readUserDatabase - - ) where - -import Control.Concurrent.STM (TVar, atomically, readTVar, writeTVar, newTVar) -import Control.Monad.State (lift, liftM) -import Data.Digest.Pure.MD5 (md5) -import Data.List (intercalate) -import Data.Maybe (catMaybes) -import Data.Record.Label -import Misc.Misc (atomModTVar, safeHead) -import Network.Protocol.Http (Status (Unauthorized, OK), status) -import Network.Salvia.Handler.Error (hCustomError, hError) -import Network.Salvia.Handler.Session -import Network.Salvia.Httpd (sendStrLn, Handler, uriEncodedPostParamsUTF8, response) -import Network.Protocol.Uri -import Data.ByteString.Lazy.UTF8 (fromString) - -------------------------------------------------------------------------------- - -type Username = String -type Password = String -type Action = String -type Actions = [Action] - -{- | -User containg a username, password and a list of actions this user is allowed -to perform within the system. --} - -data User = User { - username :: Username - , password :: Password - , email :: String - , actions :: Actions - } deriving (Eq, Show) - -type Users = [User] - -{- | -A user database containing a list of users, a list of default actions the guest -or `no-user' user is allowed to perform and a polymorphic reference to the -place the database originates from. This source field can be used by update -functions synchronizing changes back to the database. --} - -data UserDatabase src = - UserDatabase { - dbUsers :: Users - , dbGuest :: Actions - , dbSource :: src - } deriving Show - -type TUserDatabase src = TVar (UserDatabase src) - -{- | -A user payload instance contains user related session information and can be -used as the payload for regular sessions. It contains a reference to the user -it is bound to, a flag to indicate whether the user is logged in or not and a -possible user specific session payload. --} - -data UserPayload a = UserPayload { - upUser :: User - , upLoggedIn :: Bool - , upPayload :: Maybe a - } deriving (Eq, Show) - -type UserSession a = Session (UserPayload a) -type TUserSession a = TSession (UserPayload a) - -{- | A handler that requires a session with a user specific payload. -} - -type UserSessionHandler a b = SessionHandler (UserPayload a) b - -------------------------------------------------------------------------------- - -{-| -Read a user data from file. Format: /username password email action*/. --} - -readUserDatabase :: FilePath -> IO (TUserDatabase FilePath) -readUserDatabase file = do - - -- First line contains the default `guest` actions, tail lines contain users. - gst:ls <- lines `liftM` readFile file - - atomically $ newTVar $ UserDatabase - (catMaybes $ map parseUserLine ls) - (words gst) - file - where - parseUserLine line = - case words line of - user:pass:mail:acts -> Just (User user pass mail acts) - _ -> Nothing - -printUserLine :: User -> String -printUserLine u = intercalate " " ([ - username u - , password u - , email u - ] ++ actions u) - -{- | -The signup handler is used to create a new entry in the user database. It reads -a new username and password from the HTTP POST parameters and adds a new entry -in the database when no user with such name exists. The user gets the specified -initial set of actions assigned. On failure an `Unauthorized' error will be -produced. --} - -hSignup :: TUserDatabase FilePath -> Actions -> Handler () -hSignup tdb acts = do - db <- lift . atomically $ readTVar tdb - params <- uriEncodedPostParamsUTF8 - case freshUserInfo params (dbUsers db) acts of - Nothing -> hCustomError Unauthorized "signup failed" - Just u -> do - lift $ do - atomically - $ writeTVar tdb - $ UserDatabase (u : dbUsers db) (dbGuest db) (dbSource db) - appendFile (dbSource db) (printUserLine u) - -freshUserInfo :: Maybe Parameters -> Users -> Actions -> Maybe User -freshUserInfo params us acts = do - p <- params - user <- "username" `lookup` p >>= id - pass <- "password" `lookup` p >>= id - mail <- "email" `lookup` p >>= id - case safeHead $ filter ((==user).username) us of - Nothing -> return $ User user (show $ md5 $ fromString pass) mail acts - Just _ -> Nothing - -------------------------------------------------------------------------------- - -{- | -The login handler. Read the username and password values from the post data and -use that to authenticate the user. When the user can be found in the database -the user is logged in and stored in the session payload. Otherwise a -`Unauthorized' response will be sent and the user has not logged in. --} - -hLogin :: UserDatabase b -> UserSessionHandler a () -hLogin db session = do - params <- uriEncodedPostParamsUTF8 - maybe - (hCustomError Unauthorized "login failed") - (loginSuccessful session) - (authenticate params db) - -authenticate :: Maybe Parameters -> UserDatabase a -> Maybe User -authenticate params db = do - p <- params - user <- "username" `lookup` p >>= id - pass <- "password" `lookup` p >>= id - case safeHead $ filter ((==user).username) (dbUsers db) of - Nothing -> Nothing - Just u -> - if password u == (show $ md5 $ fromString pass) - then return u - else Nothing - --- Login user and create `Ok' response on successful user. -loginSuccessful :: TUserSession a -> User -> Handler () -loginSuccessful session user = do - lift $ atomModTVar (\s -> s {sPayload = Just (UserPayload user True Nothing)}) session - setM (status % response) OK - sendStrLn "login successful" - -------------------------------------------------------------------------------- - -{- | Logout the current user by emptying the session payload. -} - -hLogout :: TUserSession a -> Handler () -hLogout session = do - lift $ atomModTVar (\s -> s {sPayload = Nothing}) session - return () - -------------------------------------------------------------------------------- - -{- | -The `loginfo' handler exposes the current user session to the world using a -simple text based file. The file contains information about the current session -identifier, session start and expiration date and the possible user payload -that is included. --} - -hLoginfo :: UserSessionHandler a () -hLoginfo session = do - s' <- lift $ atomically $ readTVar session - - sendStrLn $ "sID=" ++ show (sID s') - sendStrLn $ "start=" ++ show (sStart s') - sendStrLn $ "expire=" ++ show (sExpire s') - - case sPayload s' of - Nothing -> return () - Just (UserPayload (User uname _ mail acts) _ _) -> do - sendStrLn $ "username=" ++ uname - sendStrLn $ "email=" ++ mail - sendStrLn $ "actions=" ++ intercalate " " acts - -------------------------------------------------------------------------------- - -{- | -Execute a handler only when the user for the current session is authorized to -do so. The user must have the specified action contained in its actions list in -order to be authorized. Otherwise an `Unauthorized' error will be produced. -When no user can be found in the current session or this user is not logged in -the guest account from the user database is used for authorization. --} - -hAuthorized :: - UserDatabase b -- ^ The user database to read guest account from. - -> Action -- ^ The actions that should be authorized. - -> (Maybe User -> Handler ()) -- ^ The handler to perform when authorized. - -> UserSessionHandler a () -- ^ This handler requires a user session. - -hAuthorized db action handler session = do - load <- liftM sPayload (lift $ atomically $ readTVar session) - case load of - Just (UserPayload user _ _) - | action `elem` actions user -> handler (Just user) - Nothing - | action `elem` dbGuest db -> handler Nothing - _ -> hError Unauthorized - -{- | -Execute a handler only when the user for the current session is authorized to -do so. The user must have the specified action contained in its actions list in -order to be authorized. Otherwise an `Unauthorized' error will be produced. The -guest user will not be used in any case. --} - -hAuthorizedUser :: - Action -- ^ The actions that should be authorized. - -> (User -> Handler ()) -- ^ The handler to perform when authorized. - -> UserSessionHandler a () -- ^ This handler requires a user session. - -hAuthorizedUser action handler session = do - load <- liftM sPayload (lift $ atomically $ readTVar session) - case load of - Just (UserPayload user _ _) - | action `elem` actions user -> handler user - _ -> hError Unauthorized - diff --git a/src/Network/Salvia/Handler/Method.hs b/src/Network/Salvia/Handler/Method.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Handler/Method.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Method + ( hMethod + , hMethodRouter + ) +where + +import Network.Protocol.Http +import Network.Salvia.Handler.Dispatching +import Network.Salvia.Interface + +{- | Request dispatcher based on the HTTP request `Method`. -} + +hMethod :: HttpM Request m => Dispatcher Method m a +hMethod = hRequestDispatch method (==) + +{- | Request list dispatcher based on the `hMethod` dispatcher. -} + +hMethodRouter :: HttpM Request m => ListDispatcher Method m () +hMethodRouter = hListDispatch hMethod + diff --git a/src/Network/Salvia/Handler/MethodRouter.hs b/src/Network/Salvia/Handler/MethodRouter.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/MethodRouter.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Network.Salvia.Handler.MethodRouter ( - hMethod - , hMethodRouter - - , hOPTIONS - , hGET - , hHEAD - , hPOST - , hPUT - , hDELETE - , hTRACE - , hCONNECT - ) where - -import Data.Record.Label -import Network.Protocol.Http -import Network.Salvia.Handler.Dispatching -import Network.Salvia.Handler.Error -import Network.Salvia.Httpd - -{- | -Request dispatcher based on the HTTP request `Method`. When the method does not -match an HTTP `NotFound` will be created and `Nothing` will be returned. --} - -hMethod :: Method -> Handler a -> Handler (Maybe a) -hMethod m h = hMethod' m - (Just `fmap` h) - (const Nothing `fmap` hError NotFound) - -{- | Request list dispatcher based on the `hMethod` dispatcher. -} - -hMethodRouter :: ListDispatcher Method () -hMethodRouter = hListDispatch hMethod' - -{- | Only invoke a handler on an `OPTIONS` request. -} - -hOPTIONS :: Handler a -> Handler (Maybe a) -hOPTIONS = hMethod OPTIONS - -{- | Only invoke a handler on a `GET` request. -} - -hGET :: Handler a -> Handler (Maybe a) -hGET = hMethod GET - -{- | Only invoke a handler on a `HEAD` request. -} - -hHEAD :: Handler a -> Handler (Maybe a) -hHEAD = hMethod HEAD - -{- | Only invoke a handler on a `POST` request. -} - -hPOST :: Handler a -> Handler (Maybe a) -hPOST = hMethod POST - -{- | Only invoke a handler on a `PUT` request. -} - -hPUT :: Handler a -> Handler (Maybe a) -hPUT = hMethod PUT - -{- | Only invoke a handler on a `DELETE` request. -} - -hDELETE :: Handler a -> Handler (Maybe a) -hDELETE = hMethod DELETE - -{- | Only invoke a handler on a `TRACE` request. -} - -hTRACE :: Handler a -> Handler (Maybe a) -hTRACE = hMethod TRACE - -{- | Only invoke a handler on a `CONNECT` request. -} - -hCONNECT :: Handler a -> Handler (Maybe a) -hCONNECT = hMethod CONNECT - -hMethod' :: Dispatcher Method a -hMethod' = hDispatch (method % request) (==) - diff --git a/src/Network/Salvia/Handler/Parser.hs b/src/Network/Salvia/Handler/Parser.hs --- a/src/Network/Salvia/Handler/Parser.hs +++ b/src/Network/Salvia/Handler/Parser.hs @@ -1,51 +1,83 @@ -module Network.Salvia.Handler.Parser (hParser) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Parser +( hRequestParser +, hResponseParser +, hParser +, readNonEmptyLines +) +where -import Control.Monad.State -import Data.Record.Label +import Control.Applicative +import Control.Monad.State hiding (sequence) +import Data.Traversable import Network.Protocol.Http -import Network.Salvia.Httpd +import Network.Salvia.Interface +import Network.Salvia.Handler.Error +import Prelude hiding (sequence) import System.IO -import System.Timeout +-- import System.Timeout +-- | Like the `hParser' but always parses `HTTP` `Requests`s. + +hRequestParser + :: (HandleM m, RawHttpM Request m, HttpM Request m, MonadIO m) + => Int -- ^ Timeout in milliseconds. + -> (String -> m a) -- ^ The fail handler. + -> m a -- ^ The success handler. + -> m (Maybe a) +hRequestParser = hParser pt parseRequest + where pt x = do request (put x) + rawRequest (put x) + +-- | Like the `hParser' but always parses `HTTP` `Response`s. + +hResponseParser + :: (HandleM m, RawHttpM Response m, HttpM Response m, MonadIO m) + => Int -- ^ Timeout in milliseconds. + -> (String -> m a) -- ^ The fail handler. + -> m a -- ^ The success handler. + -> m (Maybe a) +hResponseParser = hParser pt parseResponse + where pt x = do response (put x) + rawResponse (put x) + {- | -The 'hParser' handler is used to parse the raw request message into the +The 'hParser' handler is used to parse the raw `HTTP` message into the 'Message' data type. This handler is generally used as (one of) the first -handlers in an environment. The first handler argument is executed when the -request is invalid, possibly due to parser errors, and is parametrized with the -error string. The second handler argument is executed when the request is -valid. When the message could be parsed within the time specified with the -first argument the function silently returns. +handlers in a client or server environment. The first handler argument is +executed when the message is invalid, possibly due to parser errors, and is +parametrized with the error string. The second handler argument is executed +when the message is valid. When the message could not be parsed within the time +specified with the first argument the function silently returns. -} -hParser :: - Int -- ^ Timeout in milliseconds. - -> (String -> Handler ()) -- ^ The fail handler. - -> Handler () -- ^ The success handler. - -> Handler () - -hParser t onfail onsuccess = do - h <- getM sock - -- TODO use try and fail with bad request or reject silently. - mMsg <- liftIO $ timeout (t * 1000) $ - -- TODO: Using NoBuffering here may crash the entire program (GHC - -- runtime?) when processing more requests than just a few: - do hSetBuffering h (BlockBuffering (Just (64*1024))) - fmap Just (readHeader h) `catch` const (return Nothing) - case join mMsg of - Nothing -> return () - Just msg -> - do case parseRequest (msg "") of - Left err -> onfail (show err) - Right x -> do - setM request x - onsuccess +hParser + :: (HandleM m, MonadIO m) + => (Http d -> m b) -- ^ What to do with message. + -> (String -> Either String (Http d)) -- ^ Custom message parser. + -> Int -- ^ Timeout in milliseconds. + -> (String -> m a) -- ^ The fail handler. + -> m a -- ^ The success handler. + -> m (Maybe a) +hParser action parse _ onfail onsuccess = + do h <- handle + mmsg <- + liftM join + . flip catchIO Nothing + . fmap Just +-- . timeout (t * 1000) + $ do hSetBuffering h (BlockBuffering (Just (64*1024))) + Just <$> readNonEmptyLines h + let hndl = (onfail . show) `either` (\x -> action x >> onsuccess) + sequence (hndl . parse <$> mmsg) -- Read all lines until the first empty line. -readHeader :: Handle -> IO (String -> String) -readHeader h = do - l <- hGetLine h - let lf = showChar '\n' - if l `elem` ["", "\r"] - then return lf - else liftM ((showString l . lf) .) (readHeader h) +readNonEmptyLines :: Handle -> IO String +readNonEmptyLines h = ($"") <$> f + where + f = do l <- hGetLine h + let lf = showChar '\n' + if null l || l == "\r" + then return lf + else ((showString l . lf) .) <$> f diff --git a/src/Network/Salvia/Handler/Path.hs b/src/Network/Salvia/Handler/Path.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Handler/Path.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Path + ( hPath + , hPathRouter + , hPrefix + , hPrefixRouter + + , hQueryParameters + ) +where + +import Control.Category +import Data.List +import Data.Record.Label +import Network.Protocol.Http +import Network.Protocol.Uri +import Network.Salvia.Interface +import Network.Salvia.Handler.Dispatching +import Network.Salvia.Handler.Rewrite +import Prelude hiding ((.), id) + +{- | Request dispatcher based on the request path. -} + +hPath :: HttpM Request m => Dispatcher String m a +hPath p h = hRequestDispatch (path . asUri) (==) p (chop p h) + +{- | List dispatcher version of `hPath`. -} + +hPathRouter :: HttpM Request m => ListDispatcher String m a +hPathRouter = hListDispatch hPath + +{- | Request dispatcher based on a prefix of the request path. -} + +hPrefix :: HttpM Request m => Dispatcher String m a +hPrefix p h = hRequestDispatch (path . asUri) isPrefixOf p (chop p h) + +{- | List dispatcher version of `hPrefix`. -} + +hPrefixRouter :: HttpM Request m => ListDispatcher String m a +hPrefixRouter = hListDispatch hPrefix + +{- | Helper function to fetch the URI parameters from the request. -} + +hQueryParameters :: HttpM Request m => m Parameters +hQueryParameters = request (getM (queryParams . asUri)) + +-- Helper. + +chop :: HttpM Request m => String -> m a -> m a +chop a = hLocalRequest (path . asUri) (drop (length a)) + diff --git a/src/Network/Salvia/Handler/PathRouter.hs b/src/Network/Salvia/Handler/PathRouter.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/PathRouter.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Network.Salvia.Handler.PathRouter ( - hPath - , hPathRouter - , hPrefix - , hPrefixRouter - - , hParameters - ) where - -import Control.Monad.State -import Data.List (isPrefixOf) -import Data.Record.Label -import Network.Protocol.Http -import Network.Protocol.Uri (path, queryParams, Parameters) -import Network.Salvia.Handler.Dispatching -import Network.Salvia.Httpd - -{- | Request dispatcher based on the request path. -} - -hPath :: Dispatcher String a -hPath p h = hDispatch (path % uri % request) (==) p (chop p h) - -{- | List dispatcher version of `hPath`. -} - -hPathRouter :: ListDispatcher String b -hPathRouter = hListDispatch hPath - -{- | Request dispatcher based on a prefix of the request path. -} - -hPrefix :: Dispatcher String a -hPrefix p h = hDispatch (path % uri % request) isPrefixOf p (chop p h) - -{- | List dispatcher version of `hPrefix`. -} - -hPrefixRouter :: ListDispatcher String b -hPrefixRouter = hListDispatch hPrefix - -{- | Helper function to fetch the URI parameters from the request. -} - -hParameters :: Handler Parameters -hParameters = getM (uri % request) >>= return . queryParams - -chop :: String -> Handler a -> Handler a -chop a = withM (path % uri % request) (modify (drop $ length a)) - diff --git a/src/Network/Salvia/Handler/Printer.hs b/src/Network/Salvia/Handler/Printer.hs --- a/src/Network/Salvia/Handler/Printer.hs +++ b/src/Network/Salvia/Handler/Printer.hs @@ -1,15 +1,77 @@ -module Network.Salvia.Handler.Printer (hPrinter) where +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, RankNTypes #-} +module Network.Salvia.Handler.Printer +( hRequestPrinter +, hResponsePrinter +, hFlushHeaders +, hFlushHeadersOnly +, hFlushRequestHeaders +, hFlushResponseHeaders +, hFlushQueue +) +where -import Network.Salvia.Httpd +import Control.Applicative +import Control.Monad.State +import Network.Protocol.Http +import Network.Salvia.Interface +import Network.Salvia.Handler.Error +import System.IO {- | -The 'hPrinter' handler print the entire response including the headers to the -client. This handler is generally used as (one of) the last handler in a -handler environment. +The 'hRequestPrinter' handler prints the entire HTTP request including the +headers and the body to the socket towards the server. This handler is +generally used as (one of) the last handler in a server environment. -} -hPrinter :: Handler () -hPrinter = - do flushHeaders - flushQueue +hRequestPrinter :: FlushM Request m => m () +hRequestPrinter = flushHeaders forRequest >> flushQueue forRequest + +{- | +The 'hResponsePrinter' handler prints the entire HTTP response including the +headers and the body to the socket towards the client. This handler is +generally used as (one of) the last handler in a client environment. +-} + +hResponsePrinter :: FlushM Response m => m () +hResponsePrinter = flushHeaders forResponse >> flushQueue forResponse + +-- | Send all the message headers directly over the socket. + +-- | todo: printer for rawResponse over response!! + +hFlushHeaders :: forall m d. (Show (Http d), HandleM m, QueueM m, MonadIO m, HttpM d m) => d -> m () +hFlushHeaders _ = + do r <- http get :: m (Http d) + h <- handle + catchIO (hPutStr h (show r) >> hFlush h) () + +-- | Like `hFlushHeaders' but does not print status line, can be useful for CGI mode. + +hFlushHeadersOnly :: forall m d. (Show (Http d), HandleM m, QueueM m, MonadIO m, HttpM d m) => d -> m () +hFlushHeadersOnly _ = + do r <- http get :: m (Http d) + h <- handle + catchIO (hPutStr h (unlines . tail . lines $ show r) >> hFlush h) () + +-- | Like `hFlushHeaders` but specifically for the request headers. + +hFlushRequestHeaders :: FlushM Request m => m () +hFlushRequestHeaders = flushHeaders forRequest + +-- | Like `hFlushHeaders` but specifically for the response headers. + +hFlushResponseHeaders :: FlushM Response m => m () +hFlushResponseHeaders = flushHeaders forResponse + +-- | One by one apply all enqueued send actions to the socket. + +hFlushQueue :: (QueueM m, HandleM m, SocketM m, MonadIO m) => m () +hFlushQueue = + do s <- socket + h <- handle + q <- queue + flip catchIO () $ + sequence_ (map (\(SendAction f) -> f (s, h)) q) >> hFlush h + where queue = dequeue >>= maybe (return []) ((<$> queue) . (:)) + diff --git a/src/Network/Salvia/Handler/Put.hs b/src/Network/Salvia/Handler/Put.hs --- a/src/Network/Salvia/Handler/Put.hs +++ b/src/Network/Salvia/Handler/Put.hs @@ -1,26 +1,55 @@ -module Network.Salvia.Handler.Put (hPut) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.Put +( hPutFileSystem +, hPutResource +, hStore +) +where import Control.Monad.State import Network.Protocol.Http +import Network.Salvia.Interface +import Network.Salvia.Handler.Body +import Network.Salvia.Handler.Directory import Network.Salvia.Handler.Error -import Network.Salvia.Httpd +import Network.Salvia.Handler.File +import Network.Salvia.Handler.FileSystem +import Network.Salvia.Handler.Method import System.IO import qualified Data.ByteString.Lazy as B {- | -First naive handler for the HTTP `PUT` request. This probably does not handle -all the quirks that the HTTP protocol specifies, but it does the job for now. -When a 'contentLength' header field is available only this fixed number of -bytes will be spooled from socket to the resource. When both the `keepAlive' -and 'contentLength' header fields are not available the entire payload of the -request is spooled to the resource. +Create a browseable filesystem handler (like `hFileSystem') but make all files +writeable by a `PUT' request. Files that do not exists will be created as long +as the directory in which they will be created exists. -} -hPut :: ResourceHandler () -hPut name = - safeIO (openBinaryFile name WriteMode) - $ (contents >>=) . maybe putError . putOk - where - putError = hError NotImplemented - putOk fd c = lift (B.hPut fd c >> hClose fd) +hPutFileSystem :: (MonadIO m, HttpM' m, SendM m, BodyM Request m) => FilePath -> m () +hPutFileSystem = hFileTypeDispatcher hDirectoryResource (hPutResource hFileResource) + +{- | +Invokes the `hStore' handler when the request is a `PUT' request and invokes +the fallback handler otherwiser. +-} + +hPutResource + :: (MonadIO m, BodyM Request m, HttpM' m, SendM m) + => (FilePath -> m ()) -> FilePath -> m () +hPutResource def fp = hMethod PUT (hStore fp) (def fp) + +{- | +This handler takes a FilePath and will try to store the entire request body in +that file. When the request body could for some reason not be fetch a +`BadRequest' error response will be created. When an IO error occurs the +`hIOError' function is used to setup an apropriate response. +-} + +hStore + :: (MonadIO m, BodyM Request m, HttpM Response m, SendM m) + => FilePath -> m () +hStore name = + do b <- hRawRequestBody + hSafeIO + (withBinaryFile name WriteMode (flip B.hPut b)) + (const (hCustomError OK "Document stored.")) diff --git a/src/Network/Salvia/Handler/Range.hs b/src/Network/Salvia/Handler/Range.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Handler/Range.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts, TypeOperators #-} +module Network.Salvia.Handler.Range +( Range (..) +, contentRange +, range +, rangeL +) +where + +import Data.Record.Label +import Data.List +import Network.Protocol.Http +import Safe + +-- | HTTP Range datatype. + +data Range = Range (Maybe Integer) (Maybe Integer) (Maybe Integer) + deriving Show + +-- | Access the /Content-Range/ header field. + +contentRange :: Http Response :-> Maybe Range +contentRange = lmap rangeL `iso` header "Content-Range" + +-- | Access the /Range/ header field. + +range :: Http Request :-> Maybe Range +range = lmap rangeL `iso` header "Range" + +-- | Lens containing parser and pretty-printer for HTTP ranges. + +rangeL :: String :<->: Range +rangeL = parser <-> printer + where + printer (Range f t x) = concat ["bytes ", maybe "" show f, "-", maybe "" show t, maybe "" (('/':).show) x] + parser r = + case span (/='-') . maybe r id $ stripPrefix "bytes=" r of + (f, _:a) -> case span (/='/') a of + (t, _:x) -> Range (readMay f) (readMay t) (readMay x) + (t, _) -> Range (readMay f) (readMay t) Nothing + (f, []) -> Range (readMay f) Nothing Nothing + +-- If-Range: "ac5319-31f76000-481fa6ec42cc0" +-- Range: bytes=125817136- +-- Content-Range: "bytes 21010-47021/47022" +-- "ac5319-31f76000-481fa6ec42cc0" +-- Last-Modified: Wed, 17 Mar 2010 07:55:07 GMT +-- : bytes + diff --git a/src/Network/Salvia/Handler/Redirect.hs b/src/Network/Salvia/Handler/Redirect.hs --- a/src/Network/Salvia/Handler/Redirect.hs +++ b/src/Network/Salvia/Handler/Redirect.hs @@ -1,18 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} module Network.Salvia.Handler.Redirect (hRedirect) where import Data.Record.Label import Network.Protocol.Http -import Network.Protocol.Uri (URI) -import Network.Salvia.Httpd +import Network.Salvia.Interface {- | Redirect a client to another location by creating a `MovedPermanently` response message with the specified `URI` in the `location' header. -} -hRedirect :: URI -> Handler () +hRedirect :: HttpM Response m => String -> m () hRedirect u = - enterM response $ do - setM location (Just u) - setM status MovedPermanently + response $ + do location =: Just u + status =: MovedPermanently diff --git a/src/Network/Salvia/Handler/Rewrite.hs b/src/Network/Salvia/Handler/Rewrite.hs --- a/src/Network/Salvia/Handler/Rewrite.hs +++ b/src/Network/Salvia/Handler/Rewrite.hs @@ -1,60 +1,75 @@ -module Network.Salvia.Handler.Rewrite ( - hRewrite +{-# LANGUAGE FlexibleContexts, TypeOperators #-} +module Network.Salvia.Handler.Rewrite + ( hLocalRequest + + , hRewrite , hRewritePath , hRewriteHost , hRewriteExt + , hWithDir , hWithoutDir - ) where -import Control.Monad.State -import Data.List (isPrefixOf) + ) +where + +import Control.Applicative +import Control.Category +import Data.List import Data.Record.Label import Network.Protocol.Http -import Network.Protocol.Uri (URI, host, path, extension) -import Network.Salvia.Httpd +import Network.Protocol.Uri +import Network.Salvia.Interface hiding (host) +import Prelude hiding ((.), id) {- | -Run an handler in a modified context in which the request `URI` has been -changed by the specified modifier function. After the handler completes the `URI` -remains untouched. +Run a handler in a local environment in which the `HTTP' `Request' has +been modified. -} -hRewrite :: (URI -> URI) -> Handler a -> Handler a -hRewrite f = withM (uri % request) (modify f) +hLocalRequest :: HttpM Request m => (Http Request :-> b) -> (b -> b) -> m a -> m a +hLocalRequest p f m = + do u <- request (getM p) <* request (modM p f) + m <* request (p =: u) --- express these below in terms of the above? +{- | +Run an handler in a modified context in which the request `Uri` has been +changed by the specified modifier function. After the handler completes the `Uri` +remains untouched. +-} +hRewrite :: HttpM Request m => (Uri -> Uri) -> m a -> m a +hRewrite = hLocalRequest asUri + {- | Run handler in a context with a modified host. -} -hRewriteHost :: (String -> String) -> Handler a -> Handler a -hRewriteHost f = withM (host % uri % request) (modify f) +hRewriteHost :: HttpM Request m => (String -> String) -> m a -> m a +hRewriteHost = hLocalRequest (host . asUri) {- | Run handler in a context with a modified path. -} -hRewritePath :: (String -> String) -> Handler a -> Handler a -hRewritePath f = withM (path % uri % request) (modify f) +hRewritePath :: HttpM Request m => (FilePath -> FilePath) -> m a -> m a +hRewritePath = hLocalRequest (path . asUri) {- | Run handler in a context with a modified file extension. -} -hRewriteExt :: (Maybe String -> Maybe String) -> Handler a -> Handler a -hRewriteExt f = withM (extension % path % uri % request) (modify f) +hRewriteExt :: HttpM Request m => (Maybe String -> Maybe String) -> m a -> m a +hRewriteExt = hLocalRequest (extension . path . asUri) {- | Run handler in a context with a modified path. The specified prefix will be prepended to the path. -} -hWithDir :: String -> Handler a -> Handler a +hWithDir :: HttpM Request m => String -> m a -> m a hWithDir d = hRewritePath (d++) {- | Run handler in a context with a modified path. The specified prefix will be -stripped form the path. +stripped from the path. -} -hWithoutDir :: String -> Handler a -> Handler a -hWithoutDir d h = do - p <- getM (path % uri % request) - (if d `isPrefixOf` p then hRewritePath (drop $ length d) else id) h +hWithoutDir :: HttpM Request m => String -> m a -> m a +hWithoutDir d = hRewritePath $ + \p -> if d `isPrefixOf` p then drop (length d) p else p diff --git a/src/Network/Salvia/Handler/Session.hs b/src/Network/Salvia/Handler/Session.hs deleted file mode 100644 --- a/src/Network/Salvia/Handler/Session.hs +++ /dev/null @@ -1,192 +0,0 @@ -module Network.Salvia.Handler.Session ( - hSession - - , SessionID - , Session (..) - , TSession - , SessionHandler - , Sessions - - , mkSessions - ) where - -import Control.Applicative hiding (empty) -import Control.Concurrent.STM -import Control.Monad.State -import Data.Time.LocalTime -import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later) -import Network.Protocol.Cookie hiding (empty) -import Network.Salvia.Handler.Cookie -import Network.Salvia.Httpd -import Prelude hiding (lookup) -import System.Random -import qualified Data.Map as M - -------------------------------------------------------------------------------- - -{- | A session identifier. Should be unique for every session. -} - -newtype SessionID = SID Integer - deriving (Eq, Ord) - -{- | The session data type with polymorphic payload. -} - -data Session a = Session { - sID :: SessionID -- ^ A globally unique session identifier. - , sStart :: LocalTime -- ^ The time the session started. - , sExpire :: LocalTime -- ^ The time after which the session is expired. - , sPayload :: Maybe a -- ^ The information this session stores. - } deriving Show - -{- | A shared session. -} - -type TSession a = TVar (Session a) - -{- | A handler that expects a session. -} - -type SessionHandler a b = TSession a -> Handler b - -{- | Create a new, empty, shared session. -} - -mkSession :: SessionID -> LocalTime -> IO (TSession a) -mkSession sid e = do - s <- now - atomically $ newTVar $ Session sid s e Nothing - -------------------------------------------------------------------------------- - -{- | A mapping from unique session IDs to shared session variables. -} - -type Sessions a = TVar (M.Map SessionID (TSession a)) - -instance Show SessionID where - show (SID sid) = show sid - -{- | Create a new, empty, store of sessions. -} - -mkSessions :: IO (Sessions a) -mkSessions = atomically $ newTVar M.empty - -------------------------------------------------------------------------------- - -{- | -The session handler. This handler will try to return an existing session from -the sessions map based on a session identifier found in the HTTP `cookie`. When -such a session can be found the expiration date will be updated to a number of -seconds in the future. When no session can be found a new one will be created. -A cookie will be set that informs the client of the current session. --} - -hSession - :: Sessions a -- ^ Map of shared session variables. - -> Integer -- ^ Number of seconds to be added to the session expiritation time. - -> Handler (TSession a) -hSession smap expiration = do - - -- Get the session identifier from an existing cookie or create a new one. - prev <- getSessionID <$> hGetCookies - - -- Compute current time and expiration time. - (n, ex) <- lift $ liftM2 (,) now (later expiration) - - -- Either create a new session or try to reuse current one. - tsession <- - maybe - (newSession smap ex) - (existingSession smap ex n) - prev - - setSessionCookie tsession ex - return tsession - -------------------------------------------------------------------------------- - -{- -Given the (possible wrong) request cookie, try to recover the existing -- -session identifier. --} - -getSessionID :: Maybe Cookies -> Maybe SessionID -getSessionID prev = do - ck <- prev - sid <- cookie "sid" ck - sid' <- safeRead $ value sid - return (SID sid') - -{- -Generate a fresh, random session identifier using the default system random -generator. --} - -genSessionID :: IO SessionID -genSessionID = do - g <- getStdGen - let (sid, g') = random g - setStdGen g' - return (SID (abs sid)) - - -{- -This handler sets the HTTP cookie for the specified session. It will use a -default cookie with an additional `sid' attribute with the session identifier -as value. The session expiration date will be used as the cookie expire field. --} - -setSessionCookie :: TSession a -> LocalTime -> Handler () -setSessionCookie tsession ex = do - ck <- newCookie ex - sid <- lift $ liftM sID $ atomReadTVar tsession - hSetCookies $ - cookies [ck { - name = "sid" - , value = show sid - }] - -{- -Handler when no (valid) session is available. Create a new session with a -specified expiration date. The session will be stored in the session map. --} - -newSession :: Sessions a -> LocalTime -> Handler (TSession a) -newSession sessions ex = lift $ do - - -- Fresh session identifier. - sid <- genSessionID - - -- Fresh session. - session <- mkSession sid ex - - -- Place in session mapping usinf session identifier as key. - atomModTVar (M.insert sid session) sessions - return session - -{- -Handler for existing sessions. Given an existing session identifier lookup a -session from the session map. When no session is available, or the session is -expired, create a new one using the `newSession' function. Otherwise the -expiration date of the existing session is updated. --} - -existingSession :: - Sessions a -> LocalTime -> LocalTime - -> SessionID -> Handler (TSession a) -existingSession sessions ex n sid = do - - -- Lookup the session in the session map given the session identifier. - mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions) - case mtsession of - - -- Unrecognized session identifiers are penalised by a fresh session. - Nothing -> newSession sessions ex - Just tsession -> do - expd <- lift $ liftM sExpire (atomReadTVar tsession) - if expd < n - - -- Session is expired, create a new one. - then newSession sessions ex - - -- Existing session, update expiration date. - else lift $ do - atomModTVar (\s -> s {sExpire = ex}) tsession - return tsession - diff --git a/src/Network/Salvia/Handler/VirtualHosting.hs b/src/Network/Salvia/Handler/VirtualHosting.hs --- a/src/Network/Salvia/Handler/VirtualHosting.hs +++ b/src/Network/Salvia/Handler/VirtualHosting.hs @@ -1,34 +1,44 @@ -module Network.Salvia.Handler.VirtualHosting ( - hHostRouter - , hVirtualHosting - ) where +{-# LANGUAGE FlexibleContexts #-} +module Network.Salvia.Handler.VirtualHosting where -import Data.Ord +import Data.List.Split import Data.List -import Data.Record.Label -import Network.Protocol.Http +import Data.Maybe import Network.Protocol.Uri +import Network.Protocol.Http import Network.Salvia.Handler.Dispatching -import Network.Salvia.Httpd hiding (hostname) +import Network.Salvia.Interface {- | -List dispatcher based on the host part of the hostname request header. -Everything not part of the real hostname (like the port number) will be -ignored. +Dispatcher based on the host part of the `hostname' request header. Everything +not part of the real hostname (like the port number) will be ignored. When the +expected hostname starts with a dot (like ".mydomain.com") this indicates that +all sub-domains of this domain will match as well. -} -hVirtualHosting :: ListDispatcher String a -hVirtualHosting = (hListDispatch disp) . parse +hVirtualHosting :: HttpM Request m => ListDispatcher String m b +hVirtualHosting = hListDispatch (hRequestDispatch hostname (\a -> False `maybe` (match a))) where - disp = hDispatch (hostname % request) cmp - parse = map (\(a, b) -> (parseAuthority a, b)) - cmp a b = (==EQ) $ comparing (fmap (lget _host)) a b + match e f = + case parseAuthority f of + Right (Authority _ hst _) -> + case (e, hst) of + ('.':_, Hostname (Domain d)) -> filter (not . null) (splitOn "." e) `isSuffixOf` d + (_, Hostname d) -> e == show d + (_, RegName r) -> e == r + (_, IP i) -> e == show i + _ -> False {- | -List dispatcher based on the hostname request header. This header field is -parsed and interpreted as an `Authority` field. +Dispatcher based on the port number of the `hostname' request header. When no +port number is available in the hostname header port 80 will be assumed. -} -hHostRouter :: ListDispatcher (Maybe Authority) a -hHostRouter = hListDispatch $ hDispatch (hostname % request) (==) +hPortRouter :: HttpM Request m => ListDispatcher Int m b +hPortRouter = hListDispatch (hRequestDispatch hostname (\a -> False `maybe` (match a))) + where + match e f = + case parseAuthority f of + Right (Authority _ _ prt) -> fromMaybe 80 prt == e + _ -> False diff --git a/src/Network/Salvia/Handlers.hs b/src/Network/Salvia/Handlers.hs --- a/src/Network/Salvia/Handlers.hs +++ b/src/Network/Salvia/Handlers.hs @@ -1,213 +1,196 @@ -module Network.Salvia.Handlers ( - - -- * Fundamental protocol handlers. - - -- ** Default handler environments. - - hDefaultEnv - , hSessionEnv - - -- ** Parse client requests. - - , hParser - - -- ** Print server responses. - - , hPrinter - - -- ** HTTP header banner. +module Network.Salvia.Handlers {- todo doc - client/server assumptions -} +( - , hBanner +-- * Fundamental protocol handlers. - -- ** Closing or keeping alive connections. +-- ** Default handler environments. - , hCloseConn - , hKeepAlive + hDefaultEnv +, hEnvNoKeepAlive - -- ** Enable HTTP HEAD requests. - - , hHead +-- ** Parse client requests. - -- * Error handling and logging. +, hRequestParser +, hResponseParser +, hParser +, readNonEmptyLines - -- ** Default error handlers. +-- ** Print server responses. - , hError - , hCustomError - , hIOError - , safeIO +, hResponsePrinter +, hRequestPrinter +, hFlushHeaders +, hFlushHeadersOnly +, hFlushRequestHeaders +, hFlushResponseHeaders +, hFlushQueue - -- ** Logging of client requests. +-- ** Accessing request and response bodies. - , hLog - , hLogWithCounter +, hRawRequestBody +, hRawResponseBody +, hRawBody - -- ** Fallback handlers. +, hRequestBodyText +, hResponseBodyText +, hBodyText - , hOr - , hEither +, hRequestBodyStringUTF8 +, hResponseBodyStringUTF8 +, hBodyStringUTF8 - -- ** Request counter. +, hRequestParameters +, hResponseParameters +, hParameters - , hCounter +-- ** HTTP header banner. - -- * Redirecting and rewriting. +, hBanner - -- ** Redirecting the client. +-- ** Closing or keeping alive connections. - , hRedirect +, hCloseConn +, hKeepAlive - -- ** Request URI rewriting. +-- ** Enable HTTP HEAD requests. - , hRewrite - , hRewriteHost - , hRewritePath - , hRewriteExt - , hWithDir - , hWithoutDir +, hHead - -- * File and directory serving. +-- * Error handling and logging. - -- ** Serve static file resources. +-- ** Default error handlers. - , hFileResource - , hFileResourceFilter - , hResource - , hUri - , hFile - , hFileFilter +, hError +, hCustomError +, hIOError +, hSafeIO - -- ** Serve directory indices. +-- ** Logging of client requests. - , hDirectory - , hDirectoryResource +, hLog +, hDumpRequest +, hDumpResponse - -- ** Serve file system directory. +-- * Redirecting and rewriting. - , hFileTypeDispatcher - , hFileSystem - , hFileSystemNoIndexes +-- ** Redirecting the client. - -- ** Enable PUTing resources to the files ystem. +, hRedirect - , hPut +-- ** Request URI rewriting. - -- ** Serving CGI scripts. +, hRewrite +, hRewriteHost +, hRewritePath +, hRewriteExt +, hWithDir +, hWithoutDir - , hCGI +-- * File and directory serving. - -- * Dispatching. +-- ** Serve static file resources. - -- ** Custom request dispatchers. +, hFileResource +, hFileResourceFilter +, hResource +, fileMime +, hUri +, hFile +, hFileFilter - , Dispatcher - , ListDispatcher - , hDispatch - , hListDispatch +-- ** Serve directory indices. - -- ** Dispatch based on request method. +, hDirectory +, hDirectoryResource - , hMethod - , hMethodRouter +-- ** Serve file system directory. - , hOPTIONS - , hGET - , hHEAD - , hPOST - , hPUT - , hDELETE - , hTRACE - , hCONNECT +, hFileTypeDispatcher +, hFileSystem +, hFileSystemNoIndexes - -- ** Dispatch based on request path. +-- ** Enable PUTing resources to the files ystem. - , hPath - , hPathRouter - , hPrefix - , hPrefixRouter - , hParameters +, hPutFileSystem +, hPutResource +, hStore - -- ** Dispatch based on filename extension. +-- ** Support for HTTP ranges. - , hExtension - , hExtensionRouter +, Range (..) +, contentRange +, range +, rangeL - -- ** Dispatch based on host name. +-- ** Serving CGI scripts. - , hHostRouter - , hVirtualHosting +, hCGI - -- * Session and user management. +-- * Dispatching. - -- ** Cookie handling. +-- ** Custom request dispatchers. - , hSetCookies - , hGetCookies - , newCookie +, Dispatcher +, ListDispatcher +, hDispatch +, hRequestDispatch +, hListDispatch - -- ** Session management. +-- ** Dispatch based on request method. - , hSession +, hMethod +, hMethodRouter - , SessionID - , Session (..) - , TSession - , SessionHandler - , Sessions +-- ** Dispatch based on request path. - , mkSessions +, hPath +, hPathRouter +, hPrefix +, hPrefixRouter +, hQueryParameters - -- ** User management. +-- ** Dispatch based on filename extension. - , Username - , Password - , Action - , Actions - , User (..) - , Users - , UserDatabase - , TUserDatabase +, hExtension +, hExtensionRouter - , UserPayload (..) - , UserSession - , TUserSession - , UserSessionHandler +-- ** Dispatch based on host name. - , hSignup - , hLogin - , hLogout - , hLoginfo +, hVirtualHosting +, hPortRouter - , hAuthorized - , hAuthorizedUser +-- * Cookie management. - , readUserDatabase +, hSetCookie +, hCookie +, hDelCookie +, hNewCookie +) +where - ) where +-- todo: cleanup handler exports and export entire modules? import Network.Salvia.Handler.Banner +import Network.Salvia.Handler.Body import Network.Salvia.Handler.CGI import Network.Salvia.Handler.Close import Network.Salvia.Handler.Cookie -import Network.Salvia.Handler.Counter import Network.Salvia.Handler.Directory import Network.Salvia.Handler.Dispatching import Network.Salvia.Handler.Environment import Network.Salvia.Handler.Error -import Network.Salvia.Handler.ExtensionDispatcher -import Network.Salvia.Handler.Fallback +import Network.Salvia.Handler.Extension import Network.Salvia.Handler.File import Network.Salvia.Handler.FileSystem import Network.Salvia.Handler.Head import Network.Salvia.Handler.Log -import Network.Salvia.Handler.Login -import Network.Salvia.Handler.MethodRouter +import Network.Salvia.Handler.Method import Network.Salvia.Handler.Parser -import Network.Salvia.Handler.PathRouter +import Network.Salvia.Handler.Path import Network.Salvia.Handler.Printer import Network.Salvia.Handler.Put +import Network.Salvia.Handler.Range import Network.Salvia.Handler.Redirect import Network.Salvia.Handler.Rewrite -import Network.Salvia.Handler.Session import Network.Salvia.Handler.VirtualHosting diff --git a/src/Network/Salvia/Httpd.hs b/src/Network/Salvia/Httpd.hs deleted file mode 100644 --- a/src/Network/Salvia/Httpd.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Network.Salvia.Httpd ( - - -- Httpd.Core.Config - HttpdConfig (..) - , defaultConfig - - -- Httpd.Core.Handler - , Context - , config - , request - , response - , sock - , address - , queue - - , mkContext - - , Handler - , ResourceHandler - , UriHandler - - -- Httpd.Core.IO - , send - , sendStr - , sendStrLn - , sendBs - - , spool - , spoolBs - - , flushHeaders - , flushQueue - - , emptyQueue - , reset - - , contents - , contentsUtf8 - , uriEncodedPostParamsUTF8 - - -- Httpd.Core.Main - , start - - ) where - -import Network.Salvia.Core.Config -import Network.Salvia.Core.Context -import Network.Salvia.Core.Handler -import Network.Salvia.Core.IO -import Network.Salvia.Core.Main - diff --git a/src/Network/Salvia/Impl.hs b/src/Network/Salvia/Impl.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Impl.hs @@ -0,0 +1,14 @@ +module Network.Salvia.Impl +( module Network.Salvia.Impl.Config +, module Network.Salvia.Impl.Context +, module Network.Salvia.Impl.Handler +, module Network.Salvia.Impl.Server +) +where + +-- import Network.Salvia.Impl.Client +import Network.Salvia.Impl.Config +import Network.Salvia.Impl.Context +import Network.Salvia.Impl.Handler +import Network.Salvia.Impl.Server + diff --git a/src/Network/Salvia/Impl/Config.hs b/src/Network/Salvia/Impl/Config.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Impl/Config.hs @@ -0,0 +1,32 @@ +module Network.Salvia.Impl.Config where + +import Network.Socket + +{- | +The HTTP server configuration contains some network settings the server needs +know before being able to run. +-} + +data Config = + Config + { hostname :: String -- ^ Server hostname. + , adminMail :: String -- ^ Server admin email address. + , listenOn :: [SockAddr] -- ^ Address port combinations to listen on. + , backlog :: Int -- ^ TCP backlog. + } + +{- | +The default server configuration sets some safe default values. The server will +by default bind to 0.0.0.0 (`iNADDR_ANY') at port 8080. The default value for +the TCP backlog is 64. +-} + +defaultConfig :: Config +defaultConfig = + Config + { hostname = "127.0.0.1" + , adminMail = "admin@localhost" + , listenOn = [SockAddrInet 8080 iNADDR_ANY] + , backlog = 64 + } + diff --git a/src/Network/Salvia/Impl/Context.hs b/src/Network/Salvia/Impl/Context.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Impl/Context.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +module Network.Salvia.Impl.Context where + +import Data.Record.Label +import Network.Protocol.Http +import Network.Salvia.Interface +import Network.Socket +import System.IO + +{- | +A generic handler context that contains all the information needed by the +request handlers to perform their task and to set up a proper response. All the +fields in the context are accessible using the first class labels defined +below. +-} + +data Context p = Context + { _cServerHost :: String + , _cAdminMail :: String + , _cListenOn :: [SockAddr] + , _cRequest :: Http Request + , _cResponse :: Http Response + , _cRawRequest :: Http Request + , _cRawResponse :: Http Response + , _cSocket :: Socket + , _cHandle :: Handle + , _cClientAddr :: SockAddr + , _cServerAddr :: SockAddr + , _cQueue :: SendQueue + , _cPayload :: p + } deriving (Show) + +$(mkLabels [''Context]) + +-- | The server hostname. +cServerHost :: Context p :-> String + +-- | The mail address of the server adminstrator. +cAdminMail :: Context p :-> String + +-- | The socket address(es) the server is listening on. +cListenOn :: Context p :-> [SockAddr] + +-- | Connection wide payload. +cPayload :: Context p :-> p + +-- | The HTTP request header. +cRequest :: Context p :-> Http Request + +-- | The HTTP response header. +cResponse :: Context p :-> Http Response + +-- | The unaltered HTTP request header as received from a client. +cRawRequest :: Context p :-> Http Request + +-- | The plain HTTP response header unaffected by local rewriting. +cRawResponse :: Context p :-> Http Response + +-- | Raw socket for connection to the peer. +cSocket :: Context p :-> Socket + +-- | File descriptor associated with socket for the connection to the peer. +cHandle :: Context p :-> Handle + +-- | Client address. +cClientAddr :: Context p :-> SockAddr + +-- | Server address. +cServerAddr :: Context p :-> SockAddr + +-- | The queue of send actions. +cQueue :: Context p :-> SendQueue + diff --git a/src/Network/Salvia/Impl/Handler.hs b/src/Network/Salvia/Impl/Handler.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Impl/Handler.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE + FlexibleInstances + , StandaloneDeriving + , TypeSynonymInstances + , UndecidableInstances + , OverlappingInstances + , IncoherentInstances + , MultiParamTypeClasses + , GeneralizedNewtypeDeriving + , ScopedTypeVariables + #-} +module Network.Salvia.Impl.Handler where + +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.State +import Data.ByteString.Lazy.UTF8 (fromString, toString) +import Data.Monoid +import Data.Record.Label hiding (get) +import Network.Protocol.Http hiding (hostname) +import Network.Salvia.Handler.Body +import Network.Salvia.Handler.Close +import Network.Salvia.Handler.Printer +import Network.Salvia.Impl.Context +import Network.Salvia.Interface +import Prelude hiding (mod) +import Safe +import qualified Data.ByteString.Lazy as ByteString +import qualified Data.Record.Label as L + +newtype Handler p a = Handler { unHandler :: StateT (Context p) IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadState (Context p)) + +runHandler :: Handler p a -> Context p -> IO (a, Context p) +runHandler h = runStateT (unHandler h) + +instance ForkM IO (Handler p) where + forkM a = get >>= return . fmap fst . runHandler a + +instance HttpM Request (Handler p) where + http st = + do (a, s) <- runState st <$> getM cRequest + cRequest =: s >> return a + +instance HttpM Response (Handler p) where + http st = + do (a, s) <- runState st <$> getM cResponse + cResponse =: s >> return a + +instance RawHttpM Request (Handler p) where + rawHttp st = + do (a, s) <- runState st <$> getM cRawRequest + cRawRequest =: s >> return a + +instance RawHttpM Response (Handler p) where + rawHttp st = + do (a, s) <- runState st <$> getM cRawResponse + cRawResponse =: s >> return a + +instance HandleQueueM (Handler p) where + enqueueHandle f = modM cQueue (++[SendAction (f . snd)]) + +instance SocketQueueM (Handler p) where + enqueueSock f = modM cQueue (++[SendAction (f . fst)]) + +instance QueueM (Handler p) where + dequeue = headMay <$> getM cQueue <* modM cQueue (tailDef []) + +instance SendM (Handler p) where + send s = enqueueHandle (\h -> ByteString.hPut h (fromString s)) + sendBs bs = enqueueHandle (\h -> ByteString.hPutStr h bs) + spoolWith f fd = enqueueHandle (\h -> ByteString.hGetContents fd >>= ByteString.hPut h . fromString . f . toString) + spoolWithBs f fd = enqueueHandle (\h -> ByteString.hGetContents fd >>= ByteString.hPut h . f) + +instance SocketM (Handler p) where + socket = getM cSocket + +instance HandleM (Handler p) where + handle = getM cHandle + +instance ClientAddressM (Handler p) where + clientAddress = getM cClientAddr + +instance ServerAddressM (Handler p) where + serverAddress = getM cServerAddr + +instance Monoid a => Monoid (Handler p a) where + mempty = mzero >> return mempty + mappend = mplus + +instance Alternative (Handler p) where + empty = mzero + (<|>) = mplus + +instance MonadPlus (Handler p) where + mzero = + do http (status =: BadRequest) + return (error "mzero/empty") + a `mplus` b = + do r <- a + s <- http (getM status) + if statusFailure s + then do response $ + do status =: OK + contentLength =: (Nothing :: Maybe Integer) + emptyQueue >> mzero >> b + else return r + +instance FlushM Response (Handler p) where + flushHeaders = hFlushHeaders + flushQueue _ = hFlushQueue + +instance FlushM Request (Handler p) where + flushHeaders = hFlushHeaders + flushQueue _ = hFlushQueue + +instance BodyM Request (Handler p) where + body = hRawBody + +instance BodyM Response (Handler p) where + body = hRawBody + +instance ServerM (Handler p) where + host = getM cServerHost + admin = getM cAdminMail + listen = getM cListenOn + +instance Contains p (TVar q) => PayloadM p q (Handler p) where + payload st = + do pl <- getM cPayload :: Handler p p + let var = L.get select pl :: TVar q + liftIO . atomically $ + do q <- readTVar var + let (s, q') = runState st q + writeTVar var q' + return s + diff --git a/src/Network/Salvia/Impl/Server.hs b/src/Network/Salvia/Impl/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Impl/Server.hs @@ -0,0 +1,61 @@ +module Network.Salvia.Impl.Server (start) where + +import Control.Concurrent.ThreadManager +import Control.Monad.State +import Network.Protocol.Http hiding (accept, hostname) +import Network.Salvia.Impl.Config +import Network.Salvia.Impl.Context +import Network.Salvia.Impl.Handler +import Network.Socket +import System.IO + +{- | todo: +Start a webserver with a specific server configuration and default handler. The +server will go into an infinite loop and will repeatedly accept client +connections on the address and port specified in the configuration. For every +connection the specified handler will be executed with the client address and +socket stored in the handler context. +-} + +{- todo: +Start a listening TCP server on the specified address/port combination and +handle every connection with a custom handler. Accept connections on the +listening socket and pass execution to the application specific connection +handler. +-} + +start :: Config -> Handler p () -> p -> IO () +start conf handler payload = + do tm <- make + forM_ (listenOn conf) $ \(SockAddrInet port addr) -> + fork tm $ + do inet_ntoa addr >>= \a -> + putStrLn ("starting listening server on: " ++ a ++ ":" ++ show port) + s <- socket AF_INET Stream 0 + setSocketOption s ReuseAddr 1 + let sAddr = SockAddrInet port addr + bindSocket s sAddr + listen s (backlog conf) + forever $ + do (sck, cAddr) <- accept s + fork tm $ + do hndl <- socketToHandle sck ReadWriteMode + _ <- runHandler handler + Context + { _cServerHost = hostname conf + , _cAdminMail = adminMail conf + , _cListenOn = listenOn conf + , _cPayload = payload + , _cRequest = emptyRequest + , _cResponse = emptyResponse + , _cRawRequest = emptyRequest + , _cRawResponse = emptyResponse + , _cSocket = sck + , _cHandle = hndl + , _cClientAddr = cAddr + , _cServerAddr = sAddr + , _cQueue = [] + } + return () + waitForAll tm + diff --git a/src/Network/Salvia/Interface.hs b/src/Network/Salvia/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Network/Salvia/Interface.hs @@ -0,0 +1,236 @@ +{- | +This interface module contains all the basic operations to access the server +context. The interface is just of bunch of type classes that allow access to +the request and response objects. Most type classes allow access to the context +information through lifted state computations. To dig deeper into the context +object you would probably want to use the derived /fclabels/ accessors. + +Example 1: To get the entire request object: + +> do r <- request get -- Control.Monad.State.get + +Example 2: To get the request URI as a string: + +> do r <- request (getM uri) -- getM from Data.Record.Label + +Example 3: To get the query parameters and the /User-Agent/ header: + +> do request $ +> do q <- getM (queryParams . asUri) -- composed labels using the (.) from Control.Category. +> u <- header "user-agent" +> return (q, u) + +Example 4: To set the /Content-Type/ and response status and send some string. + +> do response $ +> do status =: BadRequest -- the (=:) operator from Data.Record.Label +> header "content-type" =: "text/plain" +> send "hello, world" + +-} + +{-# LANGUAGE + UndecidableInstances + , TypeOperators + , MultiParamTypeClasses + , FunctionalDependencies + , FlexibleContexts + , FlexibleInstances + , TypeFamilies + , IncoherentInstances + #-} +module Network.Salvia.Interface where + +import Control.Concurrent.STM +import Control.Applicative +import Control.Category +import Control.Monad.State hiding (get) +import Data.ByteString.Lazy (ByteString) +import Data.Record.Label +import Network.Protocol.Http +import Network.Socket +import Prelude hiding ((.), id) +import System.IO + +-- todo: comment + +class ForkM n m where + forkM :: m a -> m (n a) + +-- | The `HttpM' type class indicates is parametrized with the directon +-- (`Request' or `Response') for which the implementation should be able to +-- supply and modify the values. The `http` method allow for running arbitrary +-- state computations over the request or response objects. + +class (Applicative m, Monad m) => HttpM dir m where + http :: State (Http dir) a -> m a + +class (Applicative m, Monad m) => RawHttpM dir m where + rawHttp :: State (Http dir) a -> m a + +-- | Stub request and response used to fill in type level gaps for message +-- directions. + +forRequest :: Request +forRequest = undefined + +forResponse :: Response +forResponse = undefined + +-- | Type class alias indicating an HttpM instance for both requests and +-- responses. + +class (HttpM Request m, HttpM Response m) => HttpM' m +instance (HttpM Request m, HttpM Response m) => HttpM' m + +class (RawHttpM Request m, RawHttpM Response m) => RawHttpM' m +instance (RawHttpM Request m, RawHttpM Response m) => RawHttpM' m + +-- | Direction specific aliases for the `http' method. + +request :: HttpM Request m => State (Http Request) a -> m a +request = http + +response :: HttpM Response m => State (Http Response) a -> m a +response = http + +rawRequest :: RawHttpM Request m => State (Http Request) a -> m a +rawRequest = rawHttp + +rawResponse :: RawHttpM Response m => State (Http Response) a -> m a +rawResponse = rawHttp + +-- | The `SocketM` type class allows access to the raw socket. + +class (Applicative m, Monad m) => SocketM m where + socket :: m Socket + +-- | The `HandleM` type class allows access to the file handle, probabaly +-- associated with the socket to the peer. + +class (Applicative m, Monad m) => HandleM m where + handle :: m Handle + +-- | The `ClientAddressM` type class gives access to socket address of the +-- client part of the connection. + +class (Applicative m, Monad m) => ClientAddressM m where + clientAddress :: m SockAddr + +-- | The `ServerAddressM` type class gives access to socket address of the +-- client part of the connection. + +class (Applicative m, Monad m) => ServerAddressM m where + serverAddress :: m SockAddr + +-- | Type class alias indicating an instances for both `ClientAddressM' and +-- `ServerAddressM'. + +class (ClientAddressM m, ServerAddressM m) => AddressM' m +instance (ClientAddressM m, ServerAddressM m) => AddressM' m + +{- | +The send queue is an abstraction to make sure all data that belongs to the +message body is sent after the response headers have been sent. Instead of +sending data to client directly over the socket from the context it is +preferable to queue send actions in the context's send queue. The entire send +queue can be flushed to the client at once after the HTTP headers have been +sent at the end of a request handler. +-} + +type SendQueue = [SendAction] + +data SendAction = SendAction ((Socket, Handle) -> IO ()) + +instance Show SendAction where + show _ = "" + +-- | todo: comment: +-- The `QueueM' type class allows for queing actions for sending data values +-- over the wire. Using a queue for collecting send actions instead of directly +-- sending values over the socket allows for a more modular client or server +-- layout. + +class (Applicative m, Monad m) => HandleQueueM m where + enqueueHandle :: (Handle -> IO ()) -> m () + +class (Applicative m, Monad m) => SocketQueueM m where + enqueueSock :: (Socket -> IO ()) -> m () + +class (Applicative m, Monad m) => QueueM m where + dequeue :: m (Maybe SendAction) + +class (Applicative m, Monad m) => SendM m where + + -- | Enqueue the action of sending one regular Haskell `String' over the wire + -- to the other endpoint. + + send :: String -> m () + + -- | Enqueue the action of sending one `ByteString' over the wire to the + -- other endpoint. + + sendBs :: ByteString -> m () + + -- | Like the `spool' function but allows a custom filter over the contents. + -- the wire to the other endpoint. + + spoolWith :: (String -> String) -> Handle -> m () + + -- | Like the `spoolWith' function but uses a direct `ByteString' filter + -- which might be more efficient. + + spoolWithBs :: (ByteString -> ByteString) -> Handle -> m () + +-- | Enqueue the action of spooling the entire contents of a file handle over +-- the wire to the other endpoint. + +spool :: SendM m => Handle -> m () +spool = spoolWithBs id + +-- | The `FlushM' type class can be used to flush the message headers and the +-- message body directly over the wire to the other endpoint. + +class (Applicative m, Monad m) => FlushM dir m where + flushHeaders :: dir -> m () + flushQueue :: dir -> m () + +class (Applicative m, Monad m) => BodyM dir m where + body :: dir -> m ByteString + +-- | The `ServerM' type class can be used to acesss the static server +-- configuration like the address/port combination the server listens on and +-- the related hostname. + +class (Applicative m, Monad m) => ServerM m where + host :: m String + admin :: m String + listen :: m [SockAddr] + +-- | The `PayloadM' type class provides access to the server payload. The +-- payload can be an arbitrary piece of data that gets shared between all the +-- handlers. Can be used to implement sessions and such. Heterogeneous lists +-- implemented as right associated nested tuples can be used to store multiple +-- pieces of information and still let individual handlers pick out the right +-- thing they need. Picking the right pieces of information from the payload +-- can be done with the `select' function from the `Contains' type class. + +class (Applicative m, Monad m, Contains p (TVar q)) => PayloadM p q m | m -> p where + payload :: State q a -> m a + +infixr 5 & +(&) :: a -> b -> (a, b) +(&) a b = (a, b) + +class Contains a b where + select :: a :-> b + +instance (a ~ a') => Contains a a' where + select = id + +instance Contains (a, c) a where + select = label fst (\a (_, b) -> (a, b)) + +instance (b ~ b', Contains a b') => Contains (c, a) b' where + select = select . label snd (\b (a, _) -> (a, b)) +