network-minihttp 0.1 → 0.2

raw patch · 17 files changed

+2227/−363 lines, 17 filesdep +HsOpenSSLdep +network-connectiondep +network-dnsPVP ok

version bump matches the API change (PVP)

Dependencies added: HsOpenSSL, network-connection, network-dns, tagsoup

API changes (from Hackage documentation)

Files

• Network/MiniHTTP/Client.hs +159/−0
• Network/MiniHTTP/Connection.hs +0/−120
• Network/MiniHTTP/HTTPConnection.hs +276/−0
• Network/MiniHTTP/Marshal.hs +135/−31
• Network/MiniHTTP/MimeTypesParse.hs +11/−9
• Network/MiniHTTP/OpenID.hs +350/−0
• Network/MiniHTTP/Server.hs +226/−175
• Network/MiniHTTP/Session.hs +155/−0
• Network/MiniHTTP/URL.hs +387/−0
• examples/css/ie.css +22/−0
• examples/css/print.css +29/−0
• examples/css/screen.css +226/−0
• examples/example.tmpl +116/−0
• examples/fileserver.hs +0/−20
• examples/test.hs +82/−0
• examples/webcat.hs +34/−0
• network-minihttp.cabal +19/−8

@@ -0,0 +1,159 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module contains a very basic HTTP client. At the moment, it doesn't+--   even handle redirects for you.+--+--   Note that, in order to use SSL, you need to have the root CA certificates+--   in a PEM file in @/etc/ssh/certs.pem@ and you need to have wrapped your+--   main function in 'OpenSSL.withOpenSSL'+module Network.MiniHTTP.Client+  ( fetchBasic+  , connection+  , transport+  , request+  ) where++import           Control.Monad (when)+import           Control.Concurrent.STM+import           Control.Exception (handle, throwIO)++import qualified Data.Binary.Put as P+import qualified Data.ByteString as B+import           Data.ByteString.Internal (w2c)+import qualified Data.ByteString.Lazy as BL+import           Data.Maybe (isNothing)+import           Data.String++import qualified Network.Connection as C+import qualified Network.DNS.Client as DNS+import qualified Network.DNS.Types as DNS+import           Network.MiniHTTP.Marshal+import           Network.MiniHTTP.HTTPConnection+import qualified Network.MiniHTTP.URL as URL+import           Network.Socket++import           System.IO.Unsafe (unsafePerformIO)++import qualified OpenSSL.Session as SSL+import qualified OpenSSL.X509 as X509+++readReply :: C.Connection -> IO (Maybe (Reply, Maybe Source))+readReply conn = do+  r <- readIG conn 256 4096 parseReply+  case r of+       Nothing -> return Nothing+       Just reply ->+         case httpContentLength $ replyHeaders reply of+              Nothing ->+                if "chunked" `elem` (httpTransferEncoding $ replyHeaders reply)+                   then do+                     source <- connChunkedSource conn+                     return $ Just (reply, Just source)+                   else do+                     source <- connEOFSource conn+                     return $ Just (reply, Just source)+              Just n -> do+                source <- connSource n B.empty conn+                return $ Just (reply, Just source)++-- | A lower level HTTP client, but it allows you to perform POSTs etc+request :: C.Connection  -- ^ the connection to use+        -> Request  -- ^ a request to serialise+        -> Maybe Source  -- ^ a possible payload (for POSTs etc)+        -> IO (Maybe (Reply, Maybe Source))+request conn req msource = do+  let requestBytes = B.concat $ BL.toChunks $ P.runPut $ putRequest req+  atomically $ C.write conn requestBytes+  let lowWater = 32 * 1024++  case msource of+       (Just source) -> do+         success <- if isNothing $ httpContentLength $ reqHeaders req+                       then streamSourceChunked lowWater conn source+                       else streamSource lowWater conn source+         if not success+            then return Nothing+            else readReply conn+       Nothing -> readReply conn++globalOpenSSLClientContext :: SSL.SSLContext+globalOpenSSLClientContext = unsafePerformIO $ do+  ctx <- SSL.context+  SSL.contextSetDefaultCiphers ctx+  SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer False False+  SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"+  return ctx++-- | Construct a connection to the correct host for the given URL. (i.e.+--   resolve the hostname and create a TCP connection to the correct port).+--+--   Note that the DNS resolution (if any) doesn't block the whole process.+connection :: URL.URL+           -> IO Socket+connection (URL.URL { URL.urlHost = URL.IPv4Literal host, URL.urlPort = port }) = do+  sock <- socket AF_INET Stream 0+  connect sock $ SockAddrInet (fromIntegral port) host+  return sock++connection (URL.URL { URL.urlHost = URL.IPv6Literal host, URL.urlPort = port }) = do+  sock <- socket AF_INET6 Stream 0+  connect sock $ SockAddrInet6 (fromIntegral port) 0 host 0+  return sock++connection (URL.URL { URL.urlHost = URL.Hostname hostname, URL.urlPort = port }) = do+  r <- DNS.resolve DNS.A $ map w2c $ B.unpack hostname+  case r of+       Left error -> fail $ show error+       Right [] -> fail "DNS returned no A records"+       Right (((_, DNS.RRA (haddr:_))):_) -> do+         sock <- socket AF_INET Stream 0+         connect sock $ SockAddrInet (fromIntegral port) haddr+         return sock++-- | Setup the transport (i.e. SSL) for the given URL. In the case of a HTTP+--   scheme, this just wraps the socket in a Connection.+transport :: URL.URL -> Socket -> IO C.Connection+transport (URL.URL { URL.urlScheme = URL.HTTP }) sock =+  C.new (return ()) $ C.baseConnectionFromSocket sock++transport (URL.URL { URL.urlScheme = URL.HTTPS, URL.urlHost = URL.Hostname hostname }) sock = do+  ssl <- SSL.connection globalOpenSSLClientContext sock+  SSL.connect ssl+  verified <- SSL.getVerifyResult ssl+  when (not verified) $ fail "Failed to verify SSL server certificate"+  mcert <- SSL.getPeerCertificate ssl+  case mcert of+       Nothing -> fail "No server certificate"+       Just cert -> do+         subjects <- X509.getSubjectName cert True+         case "commonName" `lookup` subjects of+              Nothing -> fail "No hostname in certificate"+              Just h -> do+                when (fromString h /= hostname) $ fail $+                  "Hostname doesn't match certificate (" +++                   h ++ " vs " ++ show hostname ++ ")"+                conn <- C.new (return ()) $ sslToBaseConnection ssl+                return conn++transport _ _ = fail "Cannot create HTTPS connection to an IP address (cannot check certificate)"++-- | Fetch an HTTP(S) entity.+fetchBasic :: Headers  -- ^ the headers to use. This function will set the Host+                       --   header for you in the case that the URL has a+                       --   hostname in it. If in doubt, use 'emptyHeaders'+           -> URL.URL  -- ^ the resource to fetch+           -> IO (C.Connection, Reply, Maybe Source)+              -- ^ the connection (which you have to close once you are done+              --   reading the 'Source', if any), the Reply and a possible+              --   payload+fetchBasic headers url = do+  sock <- connection url+  handle (\e -> sClose sock >> throwIO e) $ do+    conn <- transport url sock+    let headers' = case URL.urlHost url of+                        URL.Hostname h -> headers { httpHost = Just h }+                        _ -> headers+    r <- request conn (Request GET (URL.toRelative url) 1 1 headers') Nothing+    case r of+         Nothing -> C.close conn >> fail "HTTP parse error"+         (Just (reply, msource)) -> return (conn, reply, msource)

@@ -1,120 +0,0 @@-module Network.MiniHTTP.Connection-  ( Connection-  , new-  , forkThreads-  , close-  , connoutq-  , connsocket-  ) where--import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception-import Control.Monad--import Data.Maybe (fromJust)-import qualified Data.ByteString as BS-import qualified Data.Sequence as Seq--import Network.Socket hiding (send, sendTo, recv, recvFrom)-import Network.Socket.ByteString--data Connection = Connection { connsocket :: Socket-                             , connoutq :: TVar (Seq.Seq BS.ByteString)-                             , connreaderthread :: TVar (Maybe ThreadId)-                             , connwriterthread :: TVar (Maybe ThreadId)-                             , conndeath :: IO ()-                             , conndead :: TVar Bool }---- Threading: each connection has two threads: one pumping data out and one--- reading it in. The failure (by throwing an exception) of either is enough--- to close the socket and kill the connection. This could happen to both at--- the same time, in which case they race to set conndead to True.--- However, we also need to record their ThreadIds in the Connection record--- so that they can kill each other. It's possible that they could try to--- kill the connection right away - before the creating thread has recorded--- the correct ThreadIds in the Connection. Thus, at startup, they both wait--- for the controlling thread to set conndead to False before doing anything--- else--new :: Socket  -- ^ the socket to make a connection from-    -> IO ()  -- ^ the action run when the connection fails-    -> STM Connection-new socket deathaction = do-  dead <- newTVar True-  outq <- newTVar Seq.empty-  p1 <- newTVar Nothing-  p2 <- newTVar Nothing--  let conn = Connection socket outq p1 p2 deathaction dead-  return conn--forkThreads :: Connection  -- ^ the connection to fork the threads for-            -> IO ()  -- ^ the action which reads from the socket-            -> IO ()-forkThreads conn readeraction = do-  reader <- forkIO $ waitForReadySignal conn $-                     connectionThreadWrapper conn connwriterthread $-                     readeraction-  writer <- forkIO $ waitForReadySignal conn $-                     connectionThreadWrapper conn connreaderthread $-                     seqToSocket (connoutq conn) (connsocket conn)-  -- update the thread ids in the Connection and set the ready flag-  atomically (writeTVar (connreaderthread conn) (Just reader) >>-              writeTVar (connwriterthread conn) (Just writer) >>-              writeTVar (conndead conn) False)-  return ()---- | Wait for conndead to be set to False on the given connection, then run---   the given action-waitForReadySignal :: Connection -> IO a -> IO a-waitForReadySignal conn action = do-  atomically (do dead <- readTVar (conndead conn)-                 if dead == True then retry else return ())-  action---- | Wrap a connection thread so that, when the thread dies, it races to set---   the dead flag. If it does so, it closes the socket and kills the other---   thread-connectionThreadWrapper :: Connection -> (Connection -> TVar (Maybe ThreadId)) -> IO a -> IO a-connectionThreadWrapper conn otherthread action = do-  finally action-          (do isDead <- atomically (do dead <- readTVar (conndead conn)-                                       when (not dead) $ writeTVar (conndead conn) True-                                       return dead)-              when (not isDead) (do t <- atomically (readTVar $ otherthread conn)-                                    killThread $ fromJust t-                                    sClose (connsocket conn)-                                    conndeath conn))---- | Close a connection-close :: Connection -> IO ()-close = sClose . connsocket---- | Atomically take elements from the end of the given sequence and write them---   to the given socket. Throw an exception when the write fails-seqToSocket :: TVar (Seq.Seq BS.ByteString)  -- ^ data is removed from the end-            -> Socket  -- ^ the socket to write to-            -> IO ()-seqToSocket q sock = do-  -- Atomically remove an element from the end of the sequence-  bs <- atomically (do q' <- readTVar q-                       (bs, rest) <--                         case Seq.viewr q' of-                              Seq.EmptyR -> retry-                              rest Seq.:> head -> return (head, rest)-                       writeTVar q rest-                       return bs)-  -- Write the data to the socket-  writea sock bs-  seqToSocket q sock---- | Write a given number of bytes to a socket.-writea :: Socket -> BS.ByteString -> IO ()-writea sock bytes-  | BS.null bytes = return ()-  | otherwise = do-    n <- send sock bytes-    if n == BS.length bytes-       then return ()-       else writea sock $ BS.drop n bytes

@@ -0,0 +1,276 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module contains many helper functions, as well the code for 'Source',+--   which is a pretty important structure+module Network.MiniHTTP.HTTPConnection+  ( -- * Sources, and related functions+    Source+  , SourceResult(..)+  , bsSource+  , hSource+  , nullSource+  , sourceToLBS+  , sourceToBS+  , connSource+  , connChunkedSource+  , connEOFSource+  , sourceDrain+  , streamSource+  , streamSourceChunked++  -- * Misc functions+  , readIG+  , sourceIG+  , maybeRead+  , sslToBaseConnection+  ) where++import           Control.Concurrent.STM+import qualified Control.Exception as Exception+import           Control.Monad (liftM)++import qualified Data.ByteString as B+import           Data.ByteString.Char8 ()+import           Data.ByteString.Internal (c2w, w2c)+import qualified Data.ByteString.Lazy.Internal as BL+import qualified Data.Binary.Strict.IncrementalGet as IG+import           Data.IORef+import           Data.Int (Int64)++import           System.IO++import           Text.Printf (printf)++import           System.IO.Unsafe (unsafeInterleaveIO)++import qualified Network.Connection as C+import           Network.Socket as Socket+import           Network.MiniHTTP.Marshal (parseChunkHeader)++import qualified OpenSSL.Session as SSL++-- | A source is a stream of data, like a lazy data structure, but without+--   some of the dangers that such entail. A source returns a 'SourceResult'+--   each time you evaluate it.+type Source = IO SourceResult++data SourceResult = SourceError  -- ^ error - please don't read this source again+                  | SourceEOF  -- ^ end of data+                  | SourceData B.ByteString  -- ^ some data+                  deriving (Show)++-- | Construct a source from a ByteString+bsSource :: B.ByteString -> IO Source+bsSource bs = do+  ref <- newIORef $ SourceData bs+  return $ do+    v <- readIORef ref+    writeIORef ref SourceEOF+    return v++-- | Construct a source from a Handle+hSource :: (Int64, Int64)  -- ^ the first and last byte to include+        -> Handle  -- ^ the handle to read from+        -> IO Source+hSource (from, to) handle = do+  bytesSoFar <- newIORef (from :: Int64)+  hSeek handle AbsoluteSeek (fromIntegral from)+  return $ do+    Exception.catch+      (do done <- readIORef bytesSoFar+          bytes <- B.hGet handle $ min (128 * 1024) (fromIntegral $ (to + 1) - done)+          if B.length bytes == 0+             then do+               if to + 1 == done+                  then return SourceEOF+                  else return SourceError+             else do modifyIORef bytesSoFar ((+) (fromIntegral $ B.length bytes))+                     return $ SourceData bytes)+      (const $ return SourceError)++-- | A source with no data (e.g. @/dev/null@)+nullSource :: Source+nullSource = return SourceEOF++-- | A source which reads from the given 'Connection' until the connection+--   signals end-of-file.+connEOFSource :: C.Connection -> IO Source+connEOFSource conn = do+  return $+    catch (liftM SourceData $ C.read conn 1024) (const $ return SourceEOF)++-- | A source which reads from a 'C.Connection'+connSource :: Int64  -- ^ the number of bytes to read+           -> B.ByteString  -- ^ a string which is prepended to the output+           -> C.Connection  -- ^ the connection to read from+           -> IO Source+connSource n bs conn =+  if fromIntegral (B.length bs) == n+     then bsSource bs+     else do+       ref <- newIORef (False, 0 :: Int64)+       return $ do+         (doneBS, n') <- readIORef ref+         if not doneBS+            then do writeIORef ref (True, fromIntegral $ B.length bs)+                    return $ SourceData bs+            else if n' == n+                    then return SourceEOF+                    else do bytes <- C.read conn $ min (32 * 1024) $ fromIntegral (n - n')+                            if B.length bytes == 0+                               then return SourceError+                               else do writeIORef ref (doneBS, n' + (fromIntegral $ B.length bytes))+                                       return $ SourceData bytes++-- | A source which reads an HTTP chunked reply from a 'C.Connection'+connChunkedSource :: C.Connection -> IO Source+connChunkedSource conn = do+  -- the contents of this reference are the number of bytes remaining in the+  -- current chunk. If zero, a chunk headers needs to be read. If < 0, we have+  -- hit EOF. If we read the end of a chunk, we always read the trailing \r\n+  -- before returning (so one need never consider that case on entry)+  ref <- newIORef (0 :: Int64)+  let f = do+        remainingInThisChunk <- readIORef ref+        case remainingInThisChunk of+             0 -> do+               m <- readIG conn 16 256 parseChunkHeader+               case m of+                    Nothing -> return SourceError+                    Just n ->+                      if n == 0+                         then C.reada conn 2 >> writeIORef ref (-1) >> return SourceEOF+                         else writeIORef ref n >> f+             (-1) -> return SourceEOF+             remainingInThisChunk -> do+               bytes <- C.read conn $ fromIntegral $ min remainingInThisChunk $ 32*1024+               if B.null bytes+                  then return SourceError+                  else do+                    let stillRemaining = remainingInThisChunk - (fromIntegral $ B.length bytes)+                    if stillRemaining == 0+                       then do+                         C.reada conn 2  -- read \r\n+                         writeIORef ref 0+                       else do+                         writeIORef ref stillRemaining+                    return $ SourceData bytes+  return f++-- | Read a source until it returns 'SourceEOF'+sourceDrain :: Source -> IO ()+sourceDrain s = do+  v <- s+  case v of+       SourceEOF -> return ()+       SourceError -> return ()+       SourceData _ -> sourceDrain s++-- | Convert a source to a lazy ByteString+sourceToLBS :: Source -> IO BL.ByteString+sourceToLBS s = do+  bytes <- s+  case bytes of+       SourceEOF -> return $ BL.Empty+       SourceError -> fail "Error in reading from client"+       SourceData bs -> do+         rest <- unsafeInterleaveIO $ sourceToLBS s+         return $ BL.Chunk bs rest++-- | Take, at most, the first n bytes from a Source and return a strict+--   ByteString. Returns Nothing on error. (A short read is not an error)+sourceToBS :: Int -> Source -> IO (Maybe B.ByteString)+sourceToBS n source = f 0 where+  f soFar = do+    s <- source+    case s of+         SourceEOF -> return $ Just B.empty+         SourceError -> return Nothing+         SourceData bs -> do+           if B.length bs + soFar >= n+              then return $ Just $ B.take (n - soFar) bs+              else do+                rest <- f (soFar + B.length bs)+                return $ (rest >>= return . B.append bs)++-- | Stream a source to a connection while not enqueuing more than lowWater+--   bytes in the outbound queue (not inc the kernel buffer)+streamSource :: Int -> C.Connection -> Source -> IO Bool+streamSource lowWater conn source = do+  next <- source+  case next of+       SourceEOF -> return True+       SourceError -> return False+       SourceData bs -> do+         atomically $ C.writeAtLowWater lowWater conn bs+         streamSource lowWater conn source++-- | Stream a source to a connection, with chunked encoding, while not+--   enqueuing more than lowWater bytes in the outbound queue (not inc the+--   kernel buffer)+streamSourceChunked :: Int -> C.Connection -> Source -> IO Bool+streamSourceChunked lowWater conn source = do+  next <- source+  case next of+       SourceEOF -> do+         atomically $ C.writeAtLowWater lowWater conn "0\r\n\r\n"+         return True+       SourceError -> return False+       SourceData bs -> do+         atomically $ C.writeAtLowWater lowWater conn $ B.pack $ map c2w $+           printf "%d\r\n\r\n" $ B.length bs+         atomically $ C.writeAtLowWater lowWater conn bs+         atomically $ C.writeAtLowWater lowWater conn "\r\n"+         streamSourceChunked lowWater conn source++-- | Run an incremental parser from the network+readIG :: C.Connection  -- ^ the connection to read from+       -> Int  -- ^ the block size to use+       -> Int  -- ^ maximum number of bytes to parse+       -> IG.Get a a -- ^ the parser+       -> IO (Maybe a)+readIG conn blockSize maxBytes parser = do+  let f sofar result+        | sofar >= maxBytes = return Nothing+        | otherwise = do+            case result of+                 IG.Failed _ -> return Nothing+                 IG.Partial cont -> C.read conn blockSize >>= \bs -> f (sofar + B.length bs) $ cont bs+                 IG.Finished rest result -> do+                   atomically $ C.pushBack conn rest+                   return $ Just result+  C.read conn blockSize >>= f 0 . IG.runGet parser++-- | Run an incremental parser from a 'Source'+sourceIG :: Source  -- ^ the source to read from+         -> Int  -- ^ the maximum number of bytes to parse+         -> IG.Get a a  -- ^ the parser+         -> IO (Maybe a)+sourceIG source maxBytes parser = do+  let f sofar result+        | sofar >= maxBytes = return Nothing+        | otherwise =+            case result of+                 IG.Failed _ -> return Nothing+                 IG.Partial cont -> do+                   s <- source+                   case s of+                        SourceError -> return Nothing+                        SourceEOF -> return Nothing+                        SourceData bytes -> f (B.length bytes + sofar) $ cont bytes+                 IG.Finished _ result -> do+                   return $ Just result+  f 0 $ IG.runGet parser B.empty++maybeRead :: Read a => B.ByteString -> Maybe a+maybeRead s = case reads $ map w2c $ B.unpack s of+                   [(x, "")] -> Just x+                   _         -> Nothing++-- | Convert an SSL connection to a BaseConnection for Network.Connection+sslToBaseConnection :: SSL.SSL -> C.BaseConnection+sslToBaseConnection ssl = C.BaseConnection r w c where+  r n = do+    bytes <- SSL.read ssl n+    return bytes+  w bs = SSL.write ssl bs >> return (B.length bs)+  c = SSL.shutdown ssl SSL.Unidirectional >> sClose (SSL.sslSocket ssl)

@@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-monomorphism-restriction                 -fno-warn-missing-signatures #-}+{-# LANGUAGE OverloadedStrings #-} -- | This module serialises and deserialises HTTP headers. It contains Haskell --   representations of request and replies and can transform them to, and from, --   the HTTP wire format.@@ -8,7 +9,9 @@   , Reply(..)   , Range(..)   , Headers(..)+  , Cookie(..)   , emptyHeaders+  , emptyCookie   , statusToMessage   , Method(..)   , MediaType@@ -16,37 +19,41 @@   , putReply   , parseRequest   , parseReply+  , parseChunkHeader   ) where -import Prelude hiding (putChar)-import Control.Monad (when)-import GHC.Exts()-import Data.Time (UTCTime(..))-import Data.Time.Format (formatTime)-import Data.Time.Calendar (fromGregorian)-import Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime)-import Data.Int (Int64)-import Data.Maybe (isJust, maybe)-import Data.List (foldl')-import System.Locale (TimeLocale(..))-import qualified Data.Map as Map-import Control.Applicative ((<|>), liftA, liftA2, (*>))+import           Prelude hiding (putChar)++import           Control.Applicative ((<|>), liftA, liftA2, (*>))+import           Control.Monad (when, forM_)+ import qualified Data.ByteString as B-import Data.ByteString.Char8 ()-import Data.ByteString.Internal (c2w, w2c)+import           Data.ByteString.Char8 ()+import           Data.ByteString.Internal (c2w, w2c) import qualified Data.Binary.Put as P-import qualified Data.Binary.Strict.Get as G-import qualified Data.Binary.Strict.Class as C import qualified Data.Binary.Strict.ByteSet as BSet+import qualified Data.Binary.Strict.Class as C+import qualified Data.Binary.Strict.Get as G+import           Data.Int (Int64)+import           Data.List (intersperse, foldl')+import qualified Data.Map as Map+import           Data.Maybe (isJust, maybe)+import           Data.String (fromString)+import           Data.Time (UTCTime(..))+import           Data.Time.Calendar (fromGregorian)+import           Data.Time.Format (formatTime)+import           Data.Time.LocalTime (TimeOfDay(..), timeOfDayToTime) -import Debug.Trace (trace)+import           GHC.Exts() -debug x = trace (show x) x+import           System.Locale (TimeLocale(..)) +import qualified Network.MiniHTTP.URL as URL+ -- | A HTTP request data Request =   Request { reqMethod :: Method-          , reqUrl :: B.ByteString+          , reqUrl :: URL.RelativeURL           , reqMajor :: Int           , reqMinor :: Int           , reqHeaders :: Headers@@ -77,6 +84,7 @@           , httpAge :: Maybe Int64           , httpAllow :: Maybe [Method]           , httpAuthorization :: Maybe B.ByteString+          , httpCookie :: [Cookie]           , httpConnectionClose :: Bool           , httpConnection :: [String]           , httpContentEncodings :: [String]@@ -104,6 +112,7 @@           , httpReferer :: Maybe B.ByteString           , httpRetryAfter :: Maybe Int64           , httpServer :: Maybe B.ByteString+          , httpSetCookie :: [Cookie]           , httpTrailer :: Maybe [String]           , httpTransferEncoding :: [String]           , httpUserAgent :: Maybe B.ByteString@@ -111,13 +120,22 @@           , httpOtherHeaders :: Map.Map B.ByteString B.ByteString           } deriving (Show) +-- | A HTTP Cookie. See <http://en.wikipedia.org/wiki/HTTP_cookie>+data Cookie = Cookie { cookieName :: B.ByteString+                     , cookieValue :: B.ByteString+                     , cookiePath :: Maybe String+                     , cookieDomain :: Maybe String+                     , cookieExpires :: Maybe UTCTime+                     , cookieSecure :: Bool+                     } deriving (Show, Eq, Ord)+ emptyHeaders :: Headers emptyHeaders =   Headers Nothing Nothing Nothing Nothing-  False Nothing Nothing Nothing False [] [] Nothing Nothing+  False Nothing Nothing Nothing [] False [] [] Nothing Nothing   Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing   Nothing Nothing Nothing Nothing Nothing Nothing Nothing-  Nothing Nothing Nothing Nothing Nothing Nothing Nothing+  Nothing Nothing Nothing Nothing Nothing Nothing Nothing []   Nothing [] Nothing Nothing Map.empty  -- | The list of valid methods, see RFC 2616 section 5.1@@ -200,7 +218,7 @@         BSet.range (c2w 'A') (c2w 'F') `BSet.union`         digits separators = BSet.fromList $ map c2w "()<>@,;:\\\"/[]?={} \t"-ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\")+--ctexts = texts `BSet.difference` (BSet.fromList $ map c2w "()\\") qdtexts = texts `BSet.difference` (BSet.fromList $ map c2w "\"\\")  --------------------------------------------------------------------------------@@ -226,11 +244,12 @@      then return 0      else return $ read $ toString r ++ replicate (3 - B.length r) '0' -comment = do+{-comment = do   char '('   comment <- C.many ((C.spanOf $ BSet.member ctexts) <|> quotedPair <|> comment) >>= return . B.concat   char ')'   return comment+-}  quotedPair = (char '\\') >> (C.getWord8 >>= return . B.singleton) @@ -346,6 +365,9 @@ int64 :: (C.BinaryParser c) => c Int64 int64 = C.spanOf1 (BSet.member digits) >>= return . readOrZero . toString +hexInt64 :: (C.BinaryParser c) => c Int64+hexInt64 = C.spanOf1 (BSet.member hexes) >>= return . readOrZero . ((++) "0x") . toString+ readOrZero "" = 0 readOrZero x = read x @@ -466,7 +488,7 @@   invalid (RangeOf a b) = a > b   invalid _ = False -headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges $ debug a } where+headerRange req = (C.string "bytes=" *> list f) >>= \a -> return $ req { httpRange = checkRanges a } where   f = a <|> b <|> c where     a = char '-' *> liftA RangeSuffix int64     b = int64 >>= (\start -> char '-' *> liftA (RangeOf start) int64)@@ -480,6 +502,42 @@ headerUserAgent req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpUserAgent = Just x } headerWWWAuthenticate req = C.remaining >>= \rem -> C.getByteString rem >>= \x -> return $ req { httpWWWAuthenticate = Just x } +emptyCookie = Cookie B.empty B.empty Nothing Nothing Nothing False++mergeCookie a b =+  Cookie { cookieName = bs cookieName+         , cookieValue = bs cookieValue+         , cookiePath = m cookiePath+         , cookieDomain = m cookieDomain+         , cookieExpires = m cookieExpires+         , cookieSecure = cookieSecure a || cookieSecure b } where+  bs f = if B.null $ f a then f b else f a+  m f = case f a of+             Nothing -> f b+             x -> x++cookie = do+  name <- C.spanOf1 (/= 0x3d {- '=' -} )+  C.word8 0x3d+  value <- C.spanOf1 (/= 0x3b {- ';' -} )++  options <- C.many $ do+    C.word8 0x3b+    lws+    key <- C.spanOf1 (BSet.member alphas)+    let value = C.spanOf1 (/= 0x3b)+    case key of+         "secure" -> return $ emptyCookie { cookieSecure = True }+         "path" -> value >>= \v -> (return $ emptyCookie { cookiePath = Just $ toString v })+         "domain" -> value >>= \v ->(return $ emptyCookie { cookieDomain = Just $ toString v })+         "expires" -> date >>= \v -> (return $ emptyCookie { cookieExpires = Just v})+         _ -> C.spanOf1 (/= 0x3d) >> return emptyCookie++  return $ foldl mergeCookie (emptyCookie { cookieName = name, cookieValue = value }) options++headerSetCookie req = cookie >>= \c -> return $ req { httpSetCookie = c : httpSetCookie req }+headerCookie req = cookie >>= \c -> return $ req { httpCookie = c : httpCookie req }+ -------------------------------------------------------------------------------- -- Top level parsing functions @@ -560,6 +618,8 @@   , ("Trailer", headerTrailer)   , ("User-Agent", headerUserAgent)   , ("WWW-Authenticate", headerWWWAuthenticate)+  , ("Cookie", headerCookie)+  , ("Set-Cookie", headerSetCookie)   ]  parseMethod :: (Monad m) => B.ByteString -> m Method@@ -578,10 +638,13 @@ parseRequest :: (C.BinaryParser m) => m Request parseRequest = do   (strmethod, url, major, minor) <- requestLine+  uri <- case URL.parseRelative url of+              Just uri -> return uri+              Nothing -> fail "Failed to parse URL"   method <- parseMethod strmethod   headers <- parseHeaders -  return $ Request method url major minor headers+  return $ Request method uri major minor headers  parseReply :: (C.BinaryParser m) => m Reply parseReply = do@@ -605,10 +668,18 @@    return req' +parseChunkHeader :: (C.BinaryParser m) => m Int64+parseChunkHeader = do+  length <- hexInt64+  C.optional lws  -- not in RFC, due to Yahoo being broken+  C.many $ char ';' >> token >> char '=' >> (token <|> quotedString)+  crlf+  return length+ -------------------------------------------------------------------------------- -- Serialisation functions -putString = P.putByteString . B.pack . map c2w+putString = P.putByteString . fromString putChar = P.putWord8 . c2w  putShow = putString . show@@ -632,12 +703,43 @@ putHeaderM (Just x) h f = P.putByteString h >> P.putByteString ": " >> f x >> P.putByteString "\r\n"  putHeaderML :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> P.Put-putHeaderML a b c = putHeaderM a b (mapM_ c)+putHeaderML a b c = putHeaderM a b (sequence_ . intersperse (P.putByteString ",") . map c) +putHeaderMLE :: Maybe [a] -> B.ByteString -> (a -> P.Put) -> B.ByteString -> P.Put+putHeaderMLE a b c extra = putHeaderM a b (sequence_ . ((:) (P.putByteString extra)) . intersperse (P.putByteString ", ") . map c)+ putHeaderL :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put putHeaderL [] _ _ = return () putHeaderL xs h f = P.putByteString h >> P.putByteString ": " >> mapM_ f xs >> P.putByteString "\r\n" +putHeaderMulti :: [a] -> B.ByteString -> (a -> P.Put) -> P.Put+putHeaderMulti vs name f = forM_ vs $ \v -> do+  P.putByteString name+  P.putByteString ": "+  f v+  P.putByteString "\r\n"++whenMaybe :: Maybe a -> (a -> P.Put) -> P.Put+whenMaybe Nothing _ = return ()+whenMaybe (Just x) f = f x++putCookie :: Cookie -> P.Put+putCookie cookie = do+  P.putByteString $ cookieName cookie+  P.putWord8 0x3d  {- '=' -}+  P.putByteString $ cookieValue cookie++  whenMaybe (cookiePath cookie) $ \s -> do+    P.putByteString "; path="+    P.putByteString $ fromString s+  whenMaybe (cookieDomain cookie) $ \s -> do+    P.putByteString "; domain="+    P.putByteString $ fromString s+  whenMaybe (cookieExpires cookie) $ \date -> do+    P.putByteString "; expires="+    putDate date+  when (cookieSecure cookie) $ P.putByteString "; secure"+ putContentRange (Just (a, b), Just c) = putShow a >> putChar '-' >> putShow b >> putChar '/' >> putShow c putContentRange (Just (a, b), Nothing) = putShow a >> putChar '-' >> putShow b >> P.putByteString "/*" putContentRange (Nothing, Just c) = P.putByteString "*/" >> putShow c@@ -707,7 +809,7 @@   putHeaderML (httpPragma headers) "Pragma" putPragma   putHeaderM (httpProxyAuthenticate headers) "Proxy-Authenticate" P.putByteString   putHeaderM (httpProxyAuthorization headers) "Proxy-Authorization" P.putByteString-  putHeaderML (httpRange headers) "Range" putRange+  putHeaderMLE (httpRange headers) "Range" putRange "bytes="   putHeaderM (httpReferer headers) "Referer" P.putByteString   putHeaderM (httpRetryAfter headers) "Retry-After" putShow   putHeaderM (httpServer headers) "Server" P.putByteString@@ -715,12 +817,14 @@   putHeaderML (httpTrailer headers) "Trailer" putString   putHeaderM (httpUserAgent headers) "User-Agent" P.putByteString   putHeaderM (httpWWWAuthenticate headers) "WWW-Authenticate" P.putByteString-  mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v) $+  putHeaderMulti (httpSetCookie headers) "Set-Cookie" putCookie+  putHeaderMulti (httpSetCookie headers) "Cookie" putCookie+  mapM_ (\(k, v) -> P.putByteString k >> putString ": " >> P.putByteString v >> P.putByteString "\r\n") $          Map.toList $ httpOtherHeaders headers  putRequest :: Request -> P.Put putRequest (Request method url major minor headers) = do-  putShow method >> putChar ' ' >> P.putByteString url >> putChar ' '+  putShow method >> putChar ' ' >> P.putByteString (URL.serialiseRelative url) >> putChar ' '   P.putByteString "HTTP/"   putShow major >> putChar '.' >> putShow minor >> P.putByteString "\r\n"   putHeaders headers

@@ -7,18 +7,20 @@   , parseMimeTypesTotal   ) where -import Prelude hiding (catch)-import Control.Applicative-import Control.Exception (catch)-import qualified Data.Map as Map-import Data.Maybe (catMaybes)+import           Prelude hiding (catch)++import           Control.Applicative+import           Control.Exception (catch)+ import qualified Data.ByteString as B-import Data.ByteString.Internal (w2c)-import qualified Data.Binary.Strict.Get as G+import           Data.ByteString.Internal (w2c)+import qualified Data.Binary.Strict.ByteSet           as BSet import qualified Data.Binary.Strict.Class as C-import qualified Data.Binary.Strict.ByteSet as BSet+import qualified Data.Binary.Strict.Get           as G+import qualified Data.Map as Map+import           Data.Maybe (catMaybes) -import Network.MiniHTTP.Marshal (MediaType)+import           Network.MiniHTTP.Marshal (MediaType)  lws = BSet.fromList [9, 32] newline = BSet.singleton 10

@@ -0,0 +1,350 @@+{-# LANGUAGE OverloadedStrings #-}+-- | This module contains support for the OpenID authentication standard. See+--   <http://www.openid.net> for details of the protocol. At the moment, only the+--   basic v2 authentication is supported. Also, we only support OpenID 2.0+--   HTML discovery, not Yadis nor XRI.+--+--   Only DH-SHA1 is used for the cryptography. This used to be SHA256, but+--   Yahoo doesn't support it (boo!)+--+--   References in this module are to the OpenID v2 spec+--      <http://openid.net/specs/openid-authentication-2_0.html>+module Network.MiniHTTP.OpenID+  ( -- * Types+    OpenIDDiscovery(..)+  , CheckIDType(..)+  , Handle+  , Key++    -- * Actions+  , findKey+  , discover+  , associate+  , checkID+  , processCheckIDReply+  ) where++import           Control.Monad (liftM)+import           Control.Concurrent.STM+import           Control.Exception (handle, throwIO)++import           Data.Bits (shiftR, xor, (.&.))+import qualified Data.Binary.Strict.Class as C+import qualified Data.Binary.Strict.Get as G+import qualified Data.ByteString as B+import           Data.ByteString.Char8 ()+import           Data.ByteString.Internal (w2c)+import qualified Data.Map as Map+import           Data.Maybe (maybe, fromJust)+import           Data.String (IsString(..))+import           Data.Time.Clock (UTCTime, getCurrentTime, addUTCTime)+import           Data.Word (Word8, Word32)++import qualified Network.Connection as C+import           Network.Socket (sClose)+import           Network.MiniHTTP.Client+import           Network.MiniHTTP.HTTPConnection+import           Network.MiniHTTP.Marshal+import qualified Network.MiniHTTP.URL as URL++import           System.IO.Unsafe (unsafePerformIO)++import           Text.HTML.TagSoup++import qualified OpenSSL.EVP.Base64 as Base64+import qualified OpenSSL.EVP.Digest as Digest+import qualified OpenSSL.BN as BN++-- | This is the result of Discovery: the OP local identity and the server HTTP+--   endpoint.+data OpenIDDiscovery =+  OpenIDDiscovery { discoveryProvider :: URL.URL+                  , discoveryLocalID :: Maybe String+                  } deriving (Show, Eq)++-- | This is the number of bytes of HTML that we'll try and read in order to+--   find the OpenID link elements+discoveryHTMLLimit :: Integral i => i+discoveryHTMLLimit = 4096++-- | Use HTML discovery to find the OpenID information for a given URL+discover :: URL.URL -> IO OpenIDDiscovery+discover uri = do+  r <- fetchBasic (emptyHeaders { httpRange = Just [RangeOf 0 discoveryHTMLLimit] }) uri+  case r of+       (conn, _, Nothing) -> do+         C.close conn+         fail "HTTP server returned no content"+       (conn, _, Just source) -> do+         let f d@(mprovider, mlocalid) (TagOpen "link" attrs) = maybe d id $ do+               rel <- "rel" `lookup` attrs+               href <- "href" `lookup` attrs+               case rel of+                    "openid2.provider" -> do+                      uri <- URL.parse $ fromString href+                      return (Just uri, mlocalid)+                    "openid2.local_id" -> return (mprovider, Just href)+                    _ -> return d++         payload <- sourceToBS 4096 source+         C.close conn+         case payload of+              Nothing -> fail "Error reading HTTP reply"+              Just payload -> do+                let (mprovider, mlocalid) =+                      foldl f (Nothing, Nothing) $ map head $+                        concatMap (sections (~== ("<link>" :: String))) $+                        sections (~== ("<head>" :: String)) $+                        parseTags $ map w2c $ B.unpack payload++                case mprovider of+                     Nothing -> fail "No provider discovered"+                     Just provider -> return $ OpenIDDiscovery provider mlocalid++-- | The default DH generator+dhG :: Integer+dhG = 2+-- | The default DH prime. See appendix B+dhP :: Integer+dhP = 0xDCF93A0B883972EC0E19989AC5A2CE310E1D37717E8D9571BB7623731866E61EF75A2E27898B057F9891C2E27A639C3F29B60814581CD3B2CA3986D2683705577D45C2E7E52DC81C7A171876E5CEA74B1448BFDFAF18828EFD2519F14E45E3826634AF1949E5B535CC829A483B8A76223E5D490A257F05BDFF16F2FB22C583AB++-- | Encode a URL of URL query key-value pairs into a query string (not+--   including the leading "?"). The string "openid." is prepended to all the+--   key names. See 4.1.2+postEncode :: Map.Map B.ByteString B.ByteString -> B.ByteString+postEncode = URL.serialiseArguments . Map.mapKeys (B.append "openid.")++-- | Encode a list of key-value pairs, in order, into the OpenID Key Value+--   format. See 4.1.1.+keyValueEncode :: [(B.ByteString, B.ByteString)] -> B.ByteString+keyValueEncode values = (B.intercalate (B.singleton 10) $ map f values) `B.append` B.singleton 10 where+  f (key, value) = key `B.append`+                   B.singleton 0x3a `B.append`+                   value++-- | A map of the default parameters included in all OpenID requests+defaultParams :: Map.Map B.ByteString B.ByteString+defaultParams = Map.fromList [("ns", "http://specs.openid.net/auth/2.0")]++-- | Convert an Integer to base64(btwoc) form. See 4.2+integerToBase64btwoc :: Integer -> IO B.ByteString+integerToBase64btwoc i = liftM (Base64.encodeBase64BS . B.drop 4) $ BN.integerToMPI i++-- | Convert a ByteString in btwoc form to an Integer. See 4.2+btwocToInteger :: B.ByteString -> IO Integer+btwocToInteger bs = do+  let len :: Word32+      len = fromIntegral $ B.length bs+      lengthbytes = B.pack $ map (\n -> fromIntegral $ (len `shiftR` n) .&. 0xff) [24, 16, 8, 0]+      mpi = lengthbytes `B.append` bs+  BN.mpiToInteger mpi++-- | The type of an OpenID handle. Handles are used to identify sessions+--   between the consumer and OP.+newtype Handle = Handle B.ByteString deriving (Show, Eq)+-- | The type of a key.+newtype Key = Key B.ByteString deriving (Show, Eq)++-- | This is the cache of association handles. It maps a string (hostname ++--   path of the OP) to a handle, key, expiry time triple.+associateCache :: TVar (Map.Map B.ByteString (Handle, Key, UTCTime))+associateCache = unsafePerformIO $ newTVarIO Map.empty++updateTVar :: TVar a -> (a -> a) -> STM ()+updateTVar var f = readTVar var >>= writeTVar var . f++-- | Lookup a key given the hostname of the OP and the handle. Generally used+--   after an indirect request to check a signature from an OP.+findKey :: B.ByteString -> Handle -> STM (Maybe Key)+findKey host (Handle handle) = do+  cache <- readTVar associateCache+  case Map.lookup host cache of+       Nothing -> return Nothing+       Just ((Handle handle'), key, _) ->+         if handle == handle'+            then return $ Just key+            else return Nothing++-- | Perform an association with a discovered OP and return either an error+--   message or a handle, a key and the number of seconds from now when the+--   handle will expire.+--+--   Internally this uses a cache so 'associate' may not actually involve an+--   HTTP request to the OP.+associate :: OpenIDDiscovery -> IO (Handle, Key)+associate discovery@(OpenIDDiscovery provider _) = do+  let cacheKey = fromString $ show provider+  currentTime <- getCurrentTime+  v <- atomically $ do+    cache <- readTVar associateCache+    case cacheKey `Map.lookup` cache of+         Nothing -> return Nothing+         Just v@(_, _, expiry) ->+           -- if the key expires in the next five minutes, dump it now+           if 300 `addUTCTime` expiry > currentTime+              then do writeTVar associateCache $ cacheKey `Map.delete` cache+                      return Nothing+              else return $ Just v+  case v of+       Just (h, k, _) -> return (h, k)+       Nothing -> do+         (h, k, secs) <- associateHTTP discovery+         let expiry = addUTCTime (fromIntegral secs) currentTime+         atomically $ do+           updateTVar associateCache (Map.insert cacheKey (h, k, expiry))+           return (h, k)++-- | Convert a URL to a Host header+urlToHost :: URL.URL -> Maybe B.ByteString+urlToHost (URL.URL {URL.urlHost = URL.Hostname h}) = Just h+urlToHost _ = Nothing++-- | An implementation of 'associate' which does an actual HTTP lookup+--   everytime. This is wrapped by 'associate', which handles caching of these+--   values. You can call this directly to bypass the cache.+associateHTTP :: OpenIDDiscovery -> IO (Handle, Key, Int)+associateHTTP (OpenIDDiscovery provider _) = do+  sock <- connection provider+  handle (\e -> sClose sock >> throwIO e) $ do+    conn <- transport provider sock+    (postbody, x) <- associateRequest+    postsource <- bsSource postbody+    r <- request conn (Request POST (URL.toRelative provider) 1 1 $+            emptyHeaders { httpHost = urlToHost provider+                         , httpContentType = Just (("application", "x-www-form-urlencoded"), [])+                         , httpContentLength = Just $ fromIntegral $ B.length postbody+                         }) $ Just postsource+    case r of+         (Just (Reply {replyStatus = 200}, Just source)) -> do+           mreplyBytes <- sourceToBS 4096 source+           C.close conn+           case mreplyBytes of+                Nothing -> fail "Error reading reply"+                Just replyBytes -> do+                  case G.runGet (parseKeyValue 10 0x3a) replyBytes of+                       (Right reply, _) -> processAssociateReply reply x+                       _ -> fail "Error parsing reply"+         _ -> print (fst $ fromJust r) >> fail "Bad HTTP reply code"++-- | Handle a reply from an associate call.+processAssociateReply :: Map.Map B.ByteString B.ByteString  -- ^ reply from the server+                      -> Integer  -- ^ the x value from associateRequest+                      -> IO (Handle, Key, Int)+                         -- ^ (handle, key, seconds to expiry)+processAssociateReply reply x =+  mapWrapper reply["assoc_handle", "dh_server_public", "enc_mac_key", "expires_in"] $+    \[handle, serverPublic, encKey, expiresStr] -> do+       Just sha1 <- Digest.getDigestByName "SHA1"+       gy <- btwocToInteger $ Base64.decodeBase64BS serverPublic+       let encKey' = Base64.decodeBase64BS encKey+           shared = BN.modexp gy x dhP+       sharedmpi <- BN.integerToMPI shared+       print encKey'+       print $ B.length encKey'+       let sharedbtwoc = B.drop 4 sharedmpi+           sharedkey = Digest.digestBS' sha1 sharedbtwoc+           key = B.pack $ B.zipWith (xor) sharedkey encKey'+       case maybeRead expiresStr of+            Nothing -> fail "Failed to parse expiry"+            Just expires -> return (Handle handle, Key key, expires)+++-- | This creates an associate request and returns the URL query and the value+--   of @x@+associateRequest :: IO (B.ByteString, Integer)+associateRequest = do+  x <- BN.randIntegerUptoNMinusOneSuchThat (/= 0) dhP+  let gxmodp = BN.modexp dhG x dhP+  encoded <- integerToBase64btwoc gxmodp++  let m = Map.union defaultParams $ Map.fromList extras+      extras = [ ("mode", "associate")+               , ("assoc_type", "HMAC-SHA1")+               , ("session_type", "DH-SHA1")+               , ("dh_consumer_public", encoded)+               ]+  print encoded+  return (postEncode m, x)++-- | A helper function which extracts a number of keys from a list, calling a+--   continuation with those values if all are found and returning a Left if+--   any are missing+mapWrapper :: Map.Map B.ByteString B.ByteString  -- ^ the map of values+           -> [B.ByteString]  -- ^ the required keys+           -> ([B.ByteString] -> IO a)  -- ^ the continuation+           -> IO a  -- ^ the result+mapWrapper m keys f =+  case mapM (flip Map.lookup m) keys of+       Nothing -> fail "Map missing required value"+       Just values -> f values++parseKeyValue :: (C.BinaryParser m)+              => Word8  -- ^ byte which breaks 'lines' (e.g. \n)+              -> Word8  -- ^ byte which breaks pairs (e.g. ':')+              -> m (Map.Map B.ByteString B.ByteString)+parseKeyValue lineBreak pairBreak = do+  let parseLine = do+        key <- C.spanOf1 (/= pairBreak)+        C.word8 pairBreak+        value <- C.spanOf1 (/= lineBreak)+        if B.isPrefixOf "openid." key+           then return (B.drop 7 key, value)+           else return (key, value)+  line <- parseLine+  rest <- C.many (C.word8 lineBreak >> parseLine)+  C.optional $ C.word8 lineBreak+  donep <- C.isEmpty+  if not donep+     then fail "Trailing garbage found"+     else return $ Map.fromList $ line : rest++-- | There are two types of checkid calls.+data CheckIDType = CheckIDSetup | CheckIDImmediate deriving (Show, Eq)++typeToString :: CheckIDType -> B.ByteString+typeToString CheckIDSetup = "checkid_setup"+typeToString CheckIDImmediate = "checkid_immediate"++-- | Construct a checkid call+checkID :: CheckIDType+        -> URL.URL  -- ^ claimed id+        -> OpenIDDiscovery -- ^ OP-local id+        -> Handle  -- ^ assoc handle+        -> B.ByteString  -- ^ return to URL+        -> Maybe B.ByteString  -- ^ trust realm+        -> URL.URL  -- ^ URL+checkID ty claimed (OpenIDDiscovery provider mlocalid) (Handle handle) returnTo realm = r where+  r = provider { URL.urlArguments = foldl Map.union Map.empty+                   [ URL.urlArguments provider+                   , Map.mapKeys (B.append "openid.") defaultParams+                   , Map.mapKeys (B.append "openid.") $ Map.fromList rest+                   ] }+  common = [ ("mode", typeToString ty)+           , ("claimed_id", URL.serialise claimed)+           , ("identity", maybe (URL.serialise claimed) fromString mlocalid)+           , ("assoc_handle", handle)+           , ("return_to", returnTo)+           ]+  rest = case realm of+              Nothing -> common+              Just realm -> ("realm", realm) : common++processCheckIDReply :: Map.Map B.ByteString B.ByteString  -- ^ the arguments+                    -> IO (Either String B.ByteString)+processCheckIDReply args' = do+  -- first strip openid. from the front of all the keys+  let args = Map.mapKeys (\k -> if "openid." `B.isPrefixOf` k then B.drop 7 k else k) args'+  Just sha1 <- Digest.getDigestByName "SHA1"+  mapWrapper args ["assoc_handle", "claimed_id", "op_endpoint", "signed", "sig"] $+    \[handle, claimed, endpoint, signed, sig] -> do+    mkey <- atomically $ findKey endpoint $ Handle handle+    case mkey of+         Nothing -> return $ Left "Cannot find assoc key"+         Just (Key key) -> do+           let signedFields = B.split 0x2c signed+            in mapWrapper args signedFields $ \signedValues -> do+                 let kv = keyValueEncode $ zip signedFields signedValues+                     mySig = Base64.encodeBase64BS $ Digest.hmacBS sha1 key kv+                 if mySig == sig+                    then return $ Right claimed+                    else return $ Left "OpenID signature verification failed"

@@ -1,22 +1,22 @@+{-# LANGUAGE OverloadedStrings #-} -- | This module contains functions for writing webservers. These servers --   process requests in a state monad pipeline and several useful actions are---   provided here in. See examples/fileserver.hs for an example of how to use---   this module.+--   provided herein.+--+--   See @examples/test.hs@ for an example of how to use this module. module Network.MiniHTTP.Server-  ( -- * Sources-    Source-  , SourceResult(..)-  , bsSource-  , hSource-  , nullSource--  -- * The processing monad-  , WebMonad-  , WebState+  ( -- * The processing monad+    WebMonad+  , WebState(..)   , getRequest+  , getPayload+  , getPOST+  , getGET   , getReply   , setReply   , setHeader+  , setCookie+  , errorPage    -- * WebMonad actions   , handleConditionalRequest@@ -26,104 +26,60 @@   , handleFromFilesystem    -- * Running the server-  , serve+  , serveHTTP+  , serveHTTPS+  , DispatchMatch(..)+  , dispatchOnURL   ) where -import Prelude hiding (foldl, elem, catch)+import           Prelude hiding (foldl, catch) -import Control.Concurrent.STM-import Control.Monad (liftM)-import Control.Monad.State.Strict-import Control.Exception (catch)+import           Control.Concurrent.STM+import           Control.Exception (catch)+import           Control.Monad.State.Strict -import Data.Foldable-import Data.Word (Word16)-import Data.Bits (shiftL, shiftR, (.|.), (.&.))-import Data.Maybe (isNothing, isJust, fromJust, catMaybes, maybe)-import Data.Time.Clock.POSIX-import Data.IORef-import Data.Int (Int64)+import qualified Data.Binary.Put as P import qualified Data.ByteString as B-import Data.ByteString.Internal (w2c, c2w)-import Data.ByteString.Char8 ()+import           Data.ByteString.Char8 () import qualified Data.ByteString.Lazy as BL+import           Data.ByteString.Internal (c2w, w2c)+import           Data.Char (chr)+import           Data.Int (Int64) import qualified Data.Map as Map-import qualified Data.Sequence as Seq-import System.IO-import System.Posix-import System.FilePath (combine, splitDirectories, joinPath, takeExtension)-import Network.Socket hiding (send, sendTo, recv, recvFrom)-import Network.Socket.ByteString-import Text.Printf (printf)--import qualified Data.Binary.Put as P-import qualified Data.Binary.Strict.IncrementalGet as IG-import Network.MiniHTTP.Marshal-import qualified Network.MiniHTTP.Connection as C-import Network.MiniHTTP.MimeTypesParse---- | This assumes a little endian system because I can't find a nice way to probe---   the endianness-htons :: Word16 -> Word16-htons x = ((x .&. 255) `shiftL` 8) .|. (x `shiftR` 8)---- | A source is a stream of data, like a lazy data structure, but without---   some of the dangers that such entail. A source returns a @SourceResult@---   each time you evaluate it.-type Source = IO SourceResult--data SourceResult = SourceError  -- ^ error - please don't read this source again-                  | SourceEOF  -- ^ end of data-                  | SourceData B.ByteString  -- ^ some data-                  deriving (Show)+import           Data.Maybe (isNothing, isJust, fromJust, catMaybes, maybe)+import           Data.String (fromString)+import           Data.Time.Clock.POSIX --- | Construct a source from a ByteString-bsSource :: B.ByteString -> IO Source-bsSource bs = do-  ref <- newIORef $ SourceData bs-  return $ do-    v <- readIORef ref-    writeIORef ref SourceEOF-    return v+import           System.FilePath (combine, splitDirectories, joinPath, takeExtension)+import           System.IO+import           System.IO.Unsafe (unsafePerformIO)+import           System.Posix+import qualified System.Posix.Signals as Signal --- | Construct a source from a Handle-hSource :: (Int64, Int64)  -- ^ the first and last byte to include-               -> Handle  -- ^ the handle to read from-               -> IO Source-hSource (from, to) handle = do-  bytesSoFar <- newIORef (from :: Int64)-  hSeek handle AbsoluteSeek (fromIntegral from)-  return $ do-    catch-      (do done <- readIORef bytesSoFar-          bytes <- B.hGet handle $ min (128 * 1024) (fromIntegral $ (to + 1) - done)-          if B.length bytes == 0-             then do-               if to + 1 == done-                  then return SourceEOF-                  else return SourceError-             else do modifyIORef bytesSoFar ((+) (fromIntegral $ B.length bytes))-                     return $ SourceData bytes)-      (const $ return SourceError)+import qualified OpenSSL.Session as SSL --- | A source with no data (e.g. /dev/null)-nullSource :: Source-nullSource = return SourceEOF+import qualified Network.Connection as C+import           Network.Socket hiding (send, sendTo, recv, recvFrom)+import           Network.MiniHTTP.Marshal+import           Network.MiniHTTP.MimeTypesParse+import           Network.MiniHTTP.HTTPConnection+import qualified Network.MiniHTTP.URL as URL --- | Processing a request involve running a number of actions in a StateT monad+-- | Processing a request involves running a number of actions in a StateT monad --   where the state for that monad is this record. This contains both a---   @Source@ and a @Handle@ element. Often something will fill in the @Handle@---   and expect later processing to convert it to a @Source@. Somehow, you have---   to end up with a @Source@, however.+--   @Source@ and a "Handle" element. Often something will fill in the "Handle"+--   and expect later processing to convert it to a "Source". Somehow, you have+--   to end up with a "Source", however. data WebState =   WebState { wsRequest :: Request  -- ^ the original request-             -- | the system mime types db, mapping file extensions+           , wsBody :: Maybe Source  -- ^ the client's payload            , wsMimeTypes :: Map.Map B.ByteString MediaType+             -- ^ the system mime types db, mapping file extensions            , wsReply :: Reply   -- ^ the current reply            , wsSource :: Maybe Source  -- ^ the current source            , wsHandle :: Maybe Handle  -- ^ the current handle-             -- | an action to be performed before sending the reply            , wsAction :: Maybe (IO ())+             -- ^ an action to be performed before sending the reply            }  -- | The processing monad@@ -137,6 +93,25 @@ getReply :: WebMonad Reply getReply = get >>= return . wsReply +-- | Return the client's request payload (if any)+getPayload :: WebMonad (Maybe Source)+getPayload = get >>= return . wsBody++-- | Get the arguments to a POST request+getPOST :: Int  -- ^ max number of bytes to read+        -> WebMonad (Map.Map B.ByteString B.ByteString)+getPOST maxBytes = do+  -- My kingdom for a MaybeT+  msource <- getPayload+  maybe (return Map.empty) (\source -> do+    mbs <- liftIO $ sourceToBS maxBytes source+    maybe (return Map.empty) (\bs -> do+      maybe (return Map.empty) return $ URL.parseArguments bs) mbs) msource++-- | Get the arguments to a GET request+getGET :: WebMonad (Map.Map B.ByteString B.ByteString)+getGET = liftM (URL.rurlArguments . reqUrl) getRequest+ -- | Set the current reply to be a reply with the given status code, the --   default message for that status code, an empty body and an empty set of --   headers.@@ -158,6 +133,16 @@   s <- get   put $ s { wsReply = reply { replyHeaders = f h } } +setCookie :: Cookie -> WebMonad ()+setCookie newcookie@(Cookie { cookieName = n }) = do+  reply <- getReply+  let h = replyHeaders reply+      sets = httpSetCookie h+      sets' = if any (\cookie -> cookieName cookie == n) sets+                 then map (\cookie -> if cookieName cookie == n then newcookie else cookie) sets+                 else newcookie : sets+  s <- get+  put $ s { wsReply = reply { replyHeaders = h { httpSetCookie = sets' } } }  -- | This handles the If-*Matches and If-*Modified conditional headers. It takes --   its information from the Last-Modified and ETag headers of the current@@ -299,131 +284,197 @@    -- stopping directory traversal needs to be done a little carefully.   -- Hopefully this is all correct-  let path = reqUrl req+  let path = map w2c $ B.unpack $ URL.rurlPath $ reqUrl req       -- First, make sure that there aren't any NULs in the path-      path' = B.takeWhile (/= 0) path-      path'' = map w2c $ B.unpack path'-      elems = splitDirectories path''+      path' = takeWhile (/= chr 0) path+      elems = splitDirectories path'       -- Remove any '..'       elems' = filter (\x -> x /= ".." && x /= "/") elems-      ext = takeExtension path''+      ext = takeExtension path'       filepath = combine docroot $ joinPath elems'   mimeTypes <- get >>= return . wsMimeTypes   s <- get-  s' <- lift $ catch+  r <- lift $ catch     (do fd <- openFd filepath ReadOnly Nothing (OpenFileFlags False False True False False)         stat <- getFdStatus fd         let size = fromIntegral $ fileSize stat             mtime = posixSecondsToUTCTime $ fromRational $ toRational $ modificationTime stat         handle <- fdToHandle fd-        return $ s { wsHandle = Just handle-                   , wsSource = Nothing-                   , wsReply = Reply 1 1 200 "Ok" $ emptyHeaders-                      { httpLastModified = Just mtime-                      , httpContentLength = Just size-                      , httpContentType = Map.lookup (B.pack $ map c2w ext) mimeTypes } } )-    (const $ return $ s { wsReply = Reply 1 1 404 "Not found" $ emptyHeaders })-  put s'+        return $ Just $+          s { wsHandle = Just handle+            , wsSource = Nothing+            , wsReply = Reply 1 1 200 "Ok" $ emptyHeaders+               { httpLastModified = Just mtime+               , httpContentLength = Just size+               , httpContentType = Map.lookup (B.pack $ map c2w ext) mimeTypes } } )+    (const $ return Nothing)+  case r of+       Just x -> put x+       Nothing -> errorPage "File not found"  pipeline :: Map.Map B.ByteString MediaType          -> WebMonad ()          -> Request+         -> Maybe Source          -> IO (Reply, Source)-pipeline mimetypes action req = do-  let initState = (WebState req mimetypes (Reply 1 1 500 "Server error" emptyHeaders)+pipeline mimetypes action req msource = do+  let initState = (WebState req msource mimetypes (Reply 1 1 500 "Server error" emptyHeaders)                    Nothing Nothing Nothing)-  (_, s) <- runStateT (do+  (_, s) <- catch (+    runStateT (do     action-    handleFinal) initState+    handleFinal) initState)+    (\e -> runStateT (do+             errorPage $ show e+             handleFinal) initState)    return (wsReply s, fromJust $ wsSource s) --- | Block until the given queue has less than the given number of bytes in it---   then enqueue a new ByteString.-waitForLowWaterAndEnqueue :: Int  -- ^ the max number of bytes in the queue before we enqueue anything-                          -> C.Connection  -- ^ the connection to write to-                          -> B.ByteString  -- ^ the data to enqueue-                          -> IO ()-waitForLowWaterAndEnqueue lw conn bs = do-  atomically $ do-    q <- readTVar $ C.connoutq conn-    let size = foldl (\sz bs -> sz + B.length bs) 0 q-    if size > lw-       then retry-       else writeTVar (C.connoutq conn) $ bs Seq.<| q- -- | Read a single request from a socket-readRequest :: Socket-            -> B.ByteString  -- ^ data which has already been read from the socket-            -> IO (B.ByteString, Request)-readRequest socket initbs = do-  let f result = do-        case result of-             IG.Failed _ -> fail "Parse failed"-             IG.Partial cont -> recv socket 256 >>= (\x -> (f $ cont x))-             IG.Finished rest result -> return (rest, result)-  f $ IG.runGet parseRequest initbs+readRequest :: C.Connection+            -> IO Request+readRequest conn = readIG conn 256 4096 parseRequest >>= return . fromJust  -- | Loop, reading and processing requests-readRequests :: (Request -> IO (Reply, IO SourceResult))+readRequests :: (Request -> Maybe Source -> IO (Reply, IO SourceResult))              -> C.Connection-             -> B.ByteString  -- ^ previously read data              -> IO ()-readRequests handler conn initbs = do-  (rest, result) <- readRequest (C.connsocket conn) initbs-  (reply, source) <- handler result+readRequests handler conn = do+  result <- readRequest conn+  body <-+    case httpContentLength $ reqHeaders result of+         Nothing -> return Nothing+         Just n -> connSource n B.empty conn >>= return . Just+  (reply, source) <- handler result body   let lowWater = 32 * 1024-      stream = do-        next <- source-        case next of-             SourceEOF -> return True-             SourceError -> return False-             SourceData bs -> waitForLowWaterAndEnqueue lowWater conn bs >> stream-      streamChunked = do-        next <- source-        case next of-             SourceEOF -> do-               waitForLowWaterAndEnqueue lowWater conn "0\r\n\r\n"-               return True-             SourceError -> return False-             SourceData bs -> do-               waitForLowWaterAndEnqueue lowWater conn $ B.pack $ map c2w $-                 printf "%d\r\n\r\n" $ B.length bs-               waitForLowWaterAndEnqueue lowWater conn bs-               waitForLowWaterAndEnqueue lowWater conn "\r\n"-               streamChunked-  waitForLowWaterAndEnqueue (32 * 1024) conn $ B.concat $ BL.toChunks $ P.runPut $ putReply reply+  atomically $ C.writeAtLowWater lowWater conn $ B.concat $ BL.toChunks $ P.runPut $ putReply reply   success <- if isNothing $ httpContentLength $ replyHeaders reply-                then streamChunked-                else stream+                then streamSourceChunked lowWater conn source+                else streamSource lowWater conn source   if not success      then C.close conn-     else readRequests handler conn rest+     else do case body of+                  Nothing -> return ()+                  Just source -> sourceDrain source+             readRequests handler conn -acceptLoop :: Socket -> (Request -> IO (Reply, Source)) -> IO ()-acceptLoop acceptingSocket handler = do+sslHandshake :: SSL.SSL -> IO () -> IO ()+sslHandshake ssl k = SSL.accept ssl >> k++acceptLoop :: (Request -> Maybe Source -> IO (Reply, Source)) -> Socket -> IO ()+acceptLoop handler acceptingSocket = do   (newsock, addr) <- accept acceptingSocket   setSocketOption newsock NoDelay 1   putStrLn $ "Connection from " ++ show addr -  c <- atomically $ C.new newsock (return ())-  C.forkThreads c $ readRequests handler c B.empty-  acceptLoop acceptingSocket handler+  c <- C.new (return ()) $ C.baseConnectionFromSocket newsock+  C.forkInConnection c $ readRequests handler c+  acceptLoop handler acceptingSocket -serve :: Int  -- ^ the port number to listen on-      -> WebMonad ()  -- ^ the processing action+acceptLoopHTTPS :: SSL.SSLContext+                -> (Request -> Maybe Source -> IO (Reply, Source))+                -> Socket+                -> IO ()+acceptLoopHTTPS ctx handler acceptingSocket = do+  (newsock, addr) <- accept acceptingSocket+  setSocketOption newsock NoDelay 1+  putStrLn $ "Connection from " ++ show addr++  ssl <- SSL.connection ctx newsock+  c <- C.new (return ()) $ sslToBaseConnection ssl+  C.forkInConnection c $ sslHandshake ssl $ readRequests handler c+  acceptLoopHTTPS ctx handler acceptingSocket++errorPage :: String -> WebMonad ()+errorPage error = (do+  s <- get+  source <- liftIO $ bsSource message+  put $ s { wsSource = Just source }+  setHeader $ \h -> h { httpContentLength = Just $ fromIntegral $ B.length message }+  handleDecoration) where+  message = head `B.append` errorbs `B.append` tail+  head = "<html> <head> <title>Network.MiniHTTP error page</title> <style language=\"text/css\"> #top { height: 1.5em; width: 100%; background-color: #BFD9FF; border-bottom: 3px solid #004FBF; margin-bottom: 2em; padding-left: 1em; font-variant: small-caps; font-size: 2em; padding-top: 0.5em; } body { margin: 0 0 0 0; } #main { margin-left: 4px; } .enbox { padding-left: 2em; background-color: \"#003786\" } h4 { color: #004FBF; } </style> </head> <body> <div id=\"top\">Network.MiniHTTP</div> <div id=\"main\"> <h4>An error occured while processing your request:</h4> <pre class=\"enbox\">"+  tail = "</pre> </div> </body> </html>"+  errorbs = fromString $ concatMap escape error+  escape '<' = "&lt;"+  escape '&' = "&amp;"+  escape '>' = "&gt;"+  escape x = [x]++data DispatchMatch = Exact B.ByteString+                   | Prefix B.ByteString+                   deriving (Show, Eq)++dispatchMatch :: B.ByteString -> DispatchMatch -> Bool+dispatchMatch b (Exact m) = b == m+dispatchMatch b (Prefix p) = p `B.isPrefixOf` b++-- | This is an, optional, helper function which you might find useful. The+--   serving fuctions both expect a "WebMonad" action which is called to+--   process each request. In general you have to write that and dispatch based+--   on the client's request.+--+--   This might save you some work: it tries each of the elements in the list+--   in turn. As soon as one matches it runs the given action to process the+--   request.+dispatchOnURL :: [(DispatchMatch, WebMonad ())]+                 -- ^ the list of URL prefixes (with '/'!) and their actions+              -> WebMonad ()+dispatchOnURL paths = do+  req <- getRequest+  let path = URL.rurlPath $ reqUrl req++  case map snd $ filter (dispatchMatch path . fst) paths of+       [] -> errorPage "No dispatchers matched requested URL"+       x:_ -> x++globalMimeTypes :: Map.Map B.ByteString MediaType+globalMimeTypes = unsafePerformIO $+  parseMimeTypesTotal "/etc/mime.types" >>= return . maybe Map.empty id++serve :: Int -- ^ port number+      -> (Socket -> IO ())  -- ^ accept loop       -> IO ()-serve portno action = do-  -- Switch these two lines to use IPv6 (which works for IPv4 clients too)+serve portno acceptLoop = do+  --  Switch these two lines to use IPv6 (which works for IPv4 clients too). Not+  --  all systems support this   --acceptingSocket <- socket AF_INET6 Stream 0-  --let sockaddr = SockAddrInet6 (PortNum $ htons $ fromIntegral portno) 0 iN6ADDR_ANY 0-+  --let sockaddr = SockAddrInet6 (fromIntegral portno) 0 iN6ADDR_ANY 0   acceptingSocket <- socket AF_INET Stream 0-  let sockaddr = SockAddrInet (PortNum $ htons $ fromIntegral portno) iNADDR_ANY+  let sockaddr = SockAddrInet (fromIntegral portno) iNADDR_ANY+   setSocketOption acceptingSocket ReuseAddr 1   bindSocket acceptingSocket sockaddr   listen acceptingSocket 1-  mimetypes <- parseMimeTypesTotal "/etc/mime.types" >>= return . maybe Map.empty id -  catch (acceptLoop acceptingSocket $ pipeline mimetypes action)+  -- Ignore SIGPIPE+  Signal.installHandler Signal.sigPIPE Signal.Ignore Nothing++  catch (acceptLoop acceptingSocket)         (const $ sClose acceptingSocket)+++-- | Start an IPv4 HTTP server+serveHTTP :: Int  -- ^ the port number to listen on+          -> WebMonad ()  -- ^ the processing action+          -> IO ()+serveHTTP portno action = do+  serve portno $ acceptLoop $ pipeline globalMimeTypes action++-- | Start an IPv4 HTTPS server. Plese remember to have wrapped your main+--   function in 'OpenSSL.withOpenSSL' otherwise you'll probably crash the+--   process.+serveHTTPS :: Int  -- ^ the port number to listen on+           -> FilePath  -- ^ path to public key (certificate)+           -> FilePath  -- ^ path to private key+           -> WebMonad ()  -- ^ the processing action+           -> IO ()+serveHTTPS portno public private action = do+  ctx <- SSL.context+  SSL.contextSetPrivateKeyFile ctx private+  SSL.contextSetCertificateFile ctx public+  SSL.contextSetDefaultCiphers ctx+  goodp <- SSL.contextCheckPrivateKey ctx+  when (not goodp) $ fail "Public/private key mismatch"++  serve portno $ acceptLoopHTTPS ctx $ pipeline globalMimeTypes action

@@ -0,0 +1,155 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Basic session support. Sessions are (currently) just maps of strings to+--   strings which are serialised and sent to the client using a Cookie.+--   Serialised, they should be less than 4K, so the sum of all your strings in+--   the map should be < 3900 bytes to be safe.+--+--   The cookies are HMACed and encrypted so that the client can't inspect nor+--   alter them. The key is, by default, generated randomly every time the+--   server starts. If you want the cookies to be reusable across restarts or+--   servers you need to set the key yourself.+--+--   Also, by the default, the cookies are set to expire when the browser+--   session ends.+module Network.MiniHTTP.Session+  ( getSession+  , putSession+  , addSession+  , setSessionSecretKey+  ) where++import           Control.Concurrent.STM+import           Control.Monad (forM_)+import           Control.Monad.Trans (liftIO)++import qualified Data.Map as Map+import qualified Data.Binary.Put           as P+import qualified Data.Binary.Strict.Get           as G+import           Data.Bits+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 ()+import qualified Data.ByteString.Lazy as BL+import           Data.ByteString.Internal (w2c)+import           Data.Word (Word32)++import           Network.MiniHTTP.Server+import           Network.MiniHTTP.Marshal++import           System.IO.Unsafe (unsafePerformIO)++import qualified OpenSSL.EVP.Base64 as Base64+import qualified OpenSSL.EVP.Cipher as Cipher+import qualified OpenSSL.EVP.Digest           as Digest+import           OpenSSL.Random (randBytes)++toString :: B.ByteString -> String+toString = map w2c . B.unpack++secretKey :: TVar B.ByteString+secretKey = unsafePerformIO $ do+  rand <- randBytes 16+  newTVarIO rand++-- | Set the secret key used to HMAC and encrypt the session cookies.+setSessionSecretKey :: B.ByteString -> STM ()+setSessionSecretKey = writeTVar secretKey++sha256 :: Digest.Digest+Just sha256 = unsafePerformIO $ Digest.getDigestByName "SHA256"+aes128 :: Cipher.Cipher+Just aes128 = unsafePerformIO $ Cipher.getCipherByName "AES128"++parseMap :: G.Get [(B.ByteString, B.ByteString)]+parseMap = do+  emptyp <- G.isEmpty+  if emptyp+     then return []+     else do+       keylen <- varInt32+       key <- G.getByteString keylen+       valuelen <- varInt32+       value <- G.getByteString valuelen+       rest <- parseMap+       rest `seq` (return $ (key, value) : rest)++putMap :: [(B.ByteString, B.ByteString)] -> P.Put+putMap vs = do+  forM_ vs $ \(key, value) -> do+    putVarInt32 $ B.length key+    P.putByteString key+    putVarInt32 $ B.length value+    P.putByteString value++decode :: B.ByteString -> IO (Map.Map B.ByteString B.ByteString)+decode bs = do+  secret <- atomically $ readTVar secretKey+  let bs' = Base64.decodeBase64BS bs+      (mac, bs'') = B.splitAt 32 bs'+  if Digest.hmacBS sha256 secret bs'' /= mac+     then return Map.empty+     else do+       let (iv, ciphertext) = B.splitAt 16 bs''+       plaintext <- Cipher.cipherBS aes128 (toString secret) (toString iv) Cipher.Decrypt ciphertext+       case G.runGet parseMap plaintext of+            (Left _, _) -> return Map.empty+            (Right m, _) -> return $ Map.fromList m++encode :: Map.Map B.ByteString B.ByteString -> IO B.ByteString+encode map = do+  secret <- atomically $ readTVar secretKey+  iv <- randBytes 16+  let plaintext = B.concat $ BL.toChunks $ P.runPut $ putMap $ Map.toList map+  ciphertext <- Cipher.cipherBS aes128 (toString secret) (toString iv) Cipher.Encrypt plaintext+  let bs = iv `B.append` ciphertext+      mac = Digest.hmacBS sha256 secret bs+  return $ Base64.encodeBase64BS $ mac `B.append` bs++-- | Return the current session. If the user didn't present a cookie, or the+--   cookie is invalid, an empty map is returned.+getSession :: WebMonad (Map.Map B.ByteString B.ByteString)+getSession = do+  req <- getRequest+  case filter (\cookie -> cookieName cookie == "nmhs") $ httpCookie $ reqHeaders req of+       [] -> return Map.empty+       x:_ -> liftIO $ decode $ cookieValue x++-- | Set the current session. This alters the headers of the current request,+--   so future actions which reset the headers (like 'setReply') will undo+--   this.+putSession :: Map.Map B.ByteString B.ByteString -> WebMonad ()+putSession m = do+  v <- liftIO $ encode m+  setCookie $ emptyCookie { cookieName = "nmhs"+                          , cookieValue = v+                          , cookiePath = Just "/" }++-- | Add a key value pair to the session+addSession :: B.ByteString -> B.ByteString -> WebMonad ()+addSession key value = do+  s <- getSession+  putSession $ Map.insert key value s++-- | This puts a generic Integral type, but first it casts to a Word32 because+--   it makes a different when it comes to negative numbers.+varInt32 :: (Integral i) => G.Get i+varInt32 = varIntWord32 >>= return . fromIntegral++varIntWord32 :: G.Get Word32+varIntWord32 = do+  byte <- G.getWord8+  if byte `testBit` 7+     then do rest <- varIntWord32+             return $ (rest `shiftL` 7) .|. (fromIntegral $ byte .&. 0x7f)+     else return $ fromIntegral byte++-- | This puts a generic Integral type, but first it casts to a Word32 because+--   it makes a difference with negative numbers+putVarInt32 :: (Integral i) => i -> P.Put+putVarInt32 = putVarWord32 . fromIntegral++putVarWord32 :: Word32 -> P.Put+putVarWord32 value+  | value < 128 = P.putWord8 $ fromIntegral value+  | otherwise = do+      P.putWord8 $ 0x80 .|. (fromIntegral $ value .&. 0x7f)+      putVarWord32 $ value `shiftR` 7

@@ -0,0 +1,387 @@+{-# LANGUAGE OverloadedStrings, ForeignFunctionInterface #-}+-- | This module contains a structure for representing web URLs. We don't try+--   to be a fully general URI parser (so no @mailto:@ etc), but it's a lot+--   better than "Network.URI" for dealing with HTTP(S)+module Network.MiniHTTP.URL+  ( URL(..)+  , RelativeURL(..)+  , Scheme(..)+  , Host(..)+  , toRelative+  , parse+  , parseRelative+  , parseArguments+  , serialise+  , serialiseRelative+  , serialiseArguments+  ) where++import           Control.Applicative(Alternative(..))+import           Control.Exception (handle)+import           Control.Monad (when, liftM)++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import           Data.ByteString.Char8 ()+import           Data.ByteString.Internal (c2w, w2c)+import qualified Data.Binary.Put as P+import qualified Data.Binary.Strict.Class as C+import qualified Data.Binary.Strict.Get as G+import qualified Data.Binary.Strict.ByteSet as BSet+import           Data.Char (toLower)+import           Data.List (intersperse)+import qualified Data.Map as Map+import           Data.Maybe (fromMaybe, isJust, catMaybes)+import           Data.String (fromString)++import           Foreign+import           Foreign.C.Types++import           System.IO.Unsafe (unsafePerformIO)++import           Text.Printf (printf)++import qualified Network.Socket as S+++-- | A web URL+data URL = URL { urlScheme :: Scheme+               , urlUser :: Maybe B.ByteString+               , urlPassword :: Maybe B.ByteString+               , urlHost :: Host+               , urlPort :: Int  -- ^ defaults based on the scheme+               , urlPath :: B.ByteString  -- ^ does not include leading '/'+               , urlArguments :: Map.Map B.ByteString B.ByteString+               , urlFragment :: Maybe B.ByteString  -- ^ doesn't include '#'+               } deriving (Eq)++instance Show URL where+  show = map w2c . B.unpack . serialise++-- | This is a relative URL. It just copies (and renames) the last three+--   members of URL. However, it's good to keep these two different types of+--   URL apart in the type system.+data RelativeURL = RelativeURL { rurlPath :: B.ByteString  -- ^ does not include leading '/'+                               , rurlArguments :: Map.Map B.ByteString B.ByteString+                               , rurlFragment :: Maybe B.ByteString+                               } deriving (Show, Eq)++-- | The transport layer to be used+data Scheme = HTTP | HTTPS deriving (Show, Eq)++-- | The host where the resource can be found+data Host = IPv4Literal S.HostAddress+          | IPv6Literal S.HostAddress6+          | Hostname B.ByteString+          deriving (Show, Eq)++wrapGet :: G.Get a -> B.ByteString -> Maybe a+wrapGet f bs =+  case G.runGet f bs of+       (Left _, _) -> Nothing+       (Right u, _) -> Just u++-- | Parse a URL+parse :: B.ByteString -> Maybe URL+parse = wrapGet parseURL++-- | Parse just an arguments map. Can be useful for POST requests. Warning: it+--   occurs to be that the arguments in a POST request might include unescaped+--   '#' symbols. In a URL that would be illegal, but the parser may need to be+--   reworked for that.+parseArguments :: B.ByteString -> Maybe (Map.Map B.ByteString B.ByteString)+parseArguments = fmap Map.fromList . wrapGet parseKVs++-- | Parse a relative URL+parseRelative :: B.ByteString -> Maybe RelativeURL+parseRelative = wrapGet parseRelativeURL++-- | Extract a relative URL from a URL+toRelative :: URL -> RelativeURL+toRelative (URL { urlPath = path, urlArguments = args, urlFragment = frag }) =+  RelativeURL path args frag++foreign import ccall unsafe "inet_ntop"+  inet_ntop :: CInt           -> Ptr Word32 -> Ptr CChar -> CSize -> IO ()++foreign import ccall unsafe "htonl"+  htonl :: Word32 -> IO Word32++serialiseIPv4 :: S.HostAddress -> B.ByteString+serialiseIPv4 v4 = unsafePerformIO $ do+  alloca $ \ptr -> do+  poke ptr v4+  allocaBytes 17 $ \str -> do+  inet_ntop (S.packFamily S.AF_INET) ptr str 17+  B.packCString str++serialiseIPv6 :: S.HostAddress6 -> B.ByteString+serialiseIPv6 (a, b, c, d) = unsafePerformIO $ do+  allocaArray 4 $ \ptr -> do+  mapM htonl [a,b,c,d] >>= pokeArray ptr+  allocaBytes 47 $ \str -> do+  inet_ntop (S.packFamily S.AF_INET6) ptr str 47+  B.packCString str++defaultPort :: Scheme -> Int+defaultPort HTTP = 80+defaultPort HTTPS = 443++doPut :: (a -> P.Put) -> a -> B.ByteString+doPut p = B.concat . BL.toChunks . P.runPut . p++-- | Convert a URL to a ByteString. It's the same as "show", except for the+--   type of the return.+serialise :: URL -> B.ByteString+serialise = doPut putURL++serialiseRelative :: RelativeURL -> B.ByteString+serialiseRelative = doPut putRelativeURL++-- | Serialise just an arguments map. Can be useful for POST requests.+serialiseArguments :: Map.Map B.ByteString B.ByteString -> B.ByteString+serialiseArguments = doPut putArguments++putURL :: URL -> P.Put+putURL url = do+  case urlScheme url of+       HTTP -> P.putByteString "http"+       HTTPS -> P.putByteString "https"+  P.putByteString "://"++  maybe (return ()) P.putByteString $ urlUser url+  maybe (return ()) (\x -> P.putWord8 (c2w ':') >> P.putByteString x) $ urlPassword url+  when (isJust (urlUser url) || isJust (urlPassword url)) $ P.putWord8 $ c2w '@'++  case urlHost url of+       IPv4Literal v4 -> P.putByteString $ serialiseIPv4 v4+       IPv6Literal v6 -> do+         P.putWord8 $ c2w '['+         P.putByteString $ serialiseIPv6 v6+         P.putWord8 $ c2w ']'+       Hostname h -> P.putByteString h++  when (urlPort url /= defaultPort (urlScheme url)) $ do+    P.putWord8 $ c2w ':'+    P.putByteString $ fromString $ show $ urlPort url++  putRelativeURL $ toRelative url++putRelativeURL :: RelativeURL -> P.Put+putRelativeURL rurl = do+  P.putWord8 $ c2w '/'+  P.putByteString $ encodeString pathSafeChars $ rurlPath rurl+  when (not $ Map.null $ rurlArguments rurl) $ do+    P.putWord8 $ c2w '?'+    putArguments $ rurlArguments rurl+    maybe (return ()) P.putByteString $ rurlFragment rurl++putArguments :: Map.Map B.ByteString B.ByteString -> P.Put+putArguments args = do+  let f ("", "") = Nothing+      f (k, "") = Just $ P.putByteString $ encodeString safeChars k+      f (k, v) = Just $ do+        P.putByteString $ encodeString safeChars k+        P.putWord8 $ c2w '='+        P.putByteString $ encodeString safeChars v+  let vs = flip map (Map.toList args) f+  sequence_ $ intersperse (P.putWord8 $ c2w '&') $ catMaybes vs++digits :: BSet.ByteSet+digits = BSet.range (c2w '0') (c2w '9')++hexChars :: BSet.ByteSet+hexChars = BSet.fromList $ map c2w "0123456789abcdefABCDEF"++isHexChar :: Word8 -> Bool+isHexChar = BSet.member hexChars++-- | The list of unsafe charactors in a URL, from RFC 1738+unsafeChars :: BSet.ByteSet+unsafeChars = BSet.range 0 0x1f `BSet.union`+              BSet.range 0x7f 0xff `BSet.union`+              BSet.fromList (map c2w "$&+,/:;=?@ \"<>#%{}[]|\\^~`")++-- | Bytes which aren't unsafe, are safe.+safeChars :: BSet.ByteSet+safeChars = BSet.complement unsafeChars++-- | These are the charactors which are safe in a path+pathSafeChars :: BSet.ByteSet+pathSafeChars = safeChars `BSet.union` BSet.singleton (c2w '/')++-- | Parse a single key, value pair+parseKV :: G.Get (B.ByteString, B.ByteString)+parseKV = do+  key <- C.spanOf (\x -> x /= c2w '#' && x /= c2w '=' && x /= c2w '&')+  value <- C.optional $ do+    C.word8 $ c2w '='+    C.spanOf (\x -> x /= c2w '#' && x /= c2w '&')++  return (decodeString key, decodeString $ fromMaybe "" value)++-- | Parse a set of URL encoded key, value pairs.+parseKVs :: G.Get [(B.ByteString, B.ByteString)]+parseKVs = do+  first <- parseKV+  rest <- C.many $ (C.word8 $ c2w '&') >> parseKV++  return $ first : rest++parseIPv6 :: G.Get B.ByteString+parseIPv6 = do+  C.word8 $ c2w '['+  s <- C.spanOf1 (/= c2w ']')+  C.word8 $ c2w ']'++  return s++toString :: B.ByteString -> String+toString = map w2c . B.unpack++parseRelativeURL :: G.Get RelativeURL+parseRelativeURL = do+  emptyp <- C.isEmpty+  if emptyp+     then return $ RelativeURL "" Map.empty Nothing+     else do+       C.word8 $ c2w '/'+       path <- C.spanOf (\x -> x /= c2w '?' && x /= c2w '#')+       margs <- C.optional $ do+         C.word8 $ c2w '?'+         liftM Map.fromList parseKVs+       mfrag <- C.optional $ do+         C.word8 $ c2w '#'+         rem <- C.remaining+         C.getByteString rem++       emptyp <- C.isEmpty+       when (not emptyp) $ fail "Trailing garbage"++       return $ RelativeURL path (fromMaybe Map.empty margs) mfrag++parseURL :: G.Get URL+parseURL = do+  scheme' <- C.spanOf1 (/= c2w ':')+  scheme <- case map (toLower . w2c) $ B.unpack scheme' of+                 "http" -> return HTTP+                 "https" -> return HTTPS+                 _ -> fail "Unknown scheme"+  C.string "://"++  muserpw <- C.optional $ do+    user <- C.spanOf (\x -> x /= c2w '@' && x /= c2w ':')+    pw <- C.optional $ do+      C.word8 $ c2w ':'+      C.spanOf (/= c2w '@')+    C.word8 $ c2w '@'+    return (user, pw)++  host' <- parseIPv6 <|> C.spanOf1 (\x -> x /= c2w ':' && x /= c2w '/')++  mhost <- return $ unsafePerformIO $ handle (const $ return Nothing) $ do+    ai <- S.getAddrInfo (Just (S.defaultHints { S.addrFlags = [S.AI_NUMERICHOST] }))+                        (Just $ toString host') Nothing+    case ai of+         [] -> return Nothing+         ai:_ ->+           case S.addrFamily ai of+                S.AF_INET ->+                  case S.addrAddress ai of+                       (S.SockAddrInet _ host) -> return $ Just $ IPv4Literal host+                       _ -> return Nothing+                S.AF_INET6 ->+                  case S.addrAddress ai of+                       (S.SockAddrInet6 _ _ host _) -> return $ Just $ IPv6Literal host+                       _ -> return Nothing+                _ -> return Nothing++  mport <- C.optional $ do+    C.word8 $ c2w ':'+    s <- C.spanOf1 $ BSet.member digits+    case reads $ map w2c $ B.unpack s of+         [(x, "")] ->+           if x > 0 && x < 65536+              then return x+              else fail "Port number out of range"+         _ -> fail "Invalid port number"++  rurl <- parseRelativeURL++  let url = URL { urlScheme = scheme+                , urlHost = case mhost of+                                 Just h -> h+                                 Nothing -> Hostname host'+                , urlPort = case mport of+                                 Just p -> p+                                 Nothing -> defaultPort scheme+                , urlPath = rurlPath rurl+                , urlArguments = rurlArguments rurl+                , urlFragment = rurlFragment rurl+                , urlUser = Nothing+                , urlPassword = Nothing }+      url'' = case muserpw of+                   Just (user, mpw) -> url { urlUser = Just user+                                           , urlPassword = mpw }+                   Nothing -> url++  return url''++toHexNibble :: Word8 -> Word8+toHexNibble 0x30 = 0+toHexNibble 0x31 = 1+toHexNibble 0x32 = 2+toHexNibble 0x33 = 3+toHexNibble 0x34 = 4+toHexNibble 0x35 = 5+toHexNibble 0x36 = 6+toHexNibble 0x37 = 7+toHexNibble 0x38 = 8+toHexNibble 0x39 = 9+toHexNibble 0x41 = 10+toHexNibble 0x42 = 11+toHexNibble 0x43 = 12+toHexNibble 0x44 = 13+toHexNibble 0x45 = 14+toHexNibble 0x46 = 15+toHexNibble 0x61 = 10+toHexNibble 0x62 = 11+toHexNibble 0x63 = 12+toHexNibble 0x64 = 13+toHexNibble 0x65 = 14+toHexNibble 0x66 = 15+toHexNibble _ = error "toHexNibble passed non-hex char"++toHexByte :: B.ByteString -> Word8+toHexByte bs = (toHexNibble (bs `B.index` 0) `shiftL` 4) .|.+               (toHexNibble (bs `B.index` 1))++-- | Replace any % escaped bytes in the given string with their Word8 values.+decodePercents :: B.ByteString -> B.ByteString+decodePercents bs = f (left, right) where+  (left, right) = B.span (/= c2w '%') bs+  f (left, right)+    | B.null right = left+    | B.length right >= 3 &&+      isHexChar (right `B.index` 1) &&+      isHexChar (right `B.index` 2) =+        left `B.append` B.singleton (toHexByte $ B.tail $ B.take 3 right) `B.append` decodeString (B.drop 3 right)+    | otherwise = bs++-- | Replace pluses in the given string with spaces and then perform percent+--   decoding.+decodeString :: B.ByteString -> B.ByteString+decodeString = decodePercents . B.map f where+  f 0x2b = 0x20+  f x = x++-- | Percent encode any unsafe bytes in the given string+encodeString :: BSet.ByteSet -> B.ByteString -> B.ByteString+encodeString safeChars bs = f (left, right) where+  (left, right) = B.span (BSet.member safeChars) bs+  f (left, right)+    | B.null right = left+    | otherwise = left `B.append` escaped `B.append` encodeString safeChars right' where+        right' = B.tail right+        unsafe = B.head right+        escaped = B.pack $ map c2w $ printf "%%%X" ((fromIntegral unsafe) :: Int)

@@ -0,0 +1,22 @@+/* -----------------------------------------------------------------------++   Blueprint CSS Framework 0.7.1+   http://blueprintcss.googlecode.com++   * Copyright (c) 2007-2008. See LICENSE for more info.+   * See README for instructions on how to use Blueprint.+   * For credits and origins, see AUTHORS.+   * This is a compressed file. See the sources in the 'src' directory.++----------------------------------------------------------------------- */++/* ie.css */+body {text-align:center;}+.container {text-align:left;}+* html .column {overflow-x:hidden;}+* html legend {margin:-18px -8px 16px 0;padding:0;}+ol {margin-left:2em;}+sup {vertical-align:text-top;}+sub {vertical-align:text-bottom;}+html>body p code {*white-space:normal;}+hr {margin:-8px auto 11px;}

@@ -0,0 +1,29 @@+/* -----------------------------------------------------------------------++   Blueprint CSS Framework 0.7.1+   http://blueprintcss.googlecode.com++   * Copyright (c) 2007-2008. See LICENSE for more info.+   * See README for instructions on how to use Blueprint.+   * For credits and origins, see AUTHORS.+   * This is a compressed file. See the sources in the 'src' directory.++----------------------------------------------------------------------- */++/* print.css */+body {line-height:1.5;font-family:"Helvetica Neue", Helvetica, Arial, sans-serif;color:#000;background:none;font-size:10pt;}+.container {background:none;}+hr {background:#ccc;color:#ccc;width:100%;height:2px;margin:2em 0;padding:0;border:none;}+hr.space {background:#fff;color:#fff;}+h1, h2, h3, h4, h5, h6 {font-family:"Helvetica Neue", Arial, "Lucida Grande", sans-serif;}+code {font:.9em "Courier New", Monaco, Courier, monospace;}+img {float:left;margin:1.5em 1.5em 1.5em 0;}+a img {border:none;}+p img.top {margin-top:0;}+blockquote {margin:1.5em;padding:1em;font-style:italic;font-size:.9em;}+.small {font-size:.9em;}+.large {font-size:1.1em;}+.quiet {color:#999;}+.hide {display:none;}+a:link, a:visited {background:transparent;font-weight:700;text-decoration:underline;}+a:link:after, a:visited:after {content:" (" attr(href) ") ";font-size:90%;}

@@ -0,0 +1,226 @@+/* -----------------------------------------------------------------------++   Blueprint CSS Framework 0.7.1+   http://blueprintcss.googlecode.com++   * Copyright (c) 2007-2008. See LICENSE for more info.+   * See README for instructions on how to use Blueprint.+   * For credits and origins, see AUTHORS.+   * This is a compressed file. See the sources in the 'src' directory.++----------------------------------------------------------------------- */++/* reset.css */+html, body, div, span, object, iframe, h1, h2, h3, h4, h5, h6, p, blockquote, pre, a, abbr, acronym, address, code, del, dfn, em, img, q, dl, dt, dd, ol, ul, li, fieldset, form, label, legend, table, caption, tbody, tfoot, thead, tr, th, td {margin:0;padding:0;border:0;font-weight:inherit;font-style:inherit;font-size:100%;font-family:inherit;vertical-align:baseline;}+body {line-height:1.5;}+table {border-collapse:separate;border-spacing:0;}+caption, th, td {text-align:left;font-weight:normal;}+table, td, th {vertical-align:middle;}+blockquote:before, blockquote:after, q:before, q:after {content:"";}+blockquote, q {quotes:"" "";}+a img {border:none;}++/* typography.css */+body {font-size:75%;color:#222;background:#fff;font-family:"Helvetica Neue", Helvetica, Arial, sans-serif;}+h1, h2, h3, h4, h5, h6 {font-weight:normal;color:#111;}+h1 {font-size:3em;line-height:1;margin-bottom:0.5em;}+h2 {font-size:2em;margin-bottom:0.75em;}+h3 {font-size:1.5em;line-height:1;margin-bottom:1em;}+h4 {font-size:1.2em;line-height:1.25;margin-bottom:1.25em;height:1.25em;}+h5 {font-size:1em;font-weight:bold;margin-bottom:1.5em;}+h6 {font-size:1em;font-weight:bold;}+h1 img, h2 img, h3 img, h4 img, h5 img, h6 img {margin:0;}+p {margin:0 0 1.5em;}+p img {float:left;margin:1.5em 1.5em 1.5em 0;padding:0;}+p img.right {float:right;margin:1.5em 0 1.5em 1.5em;}+a:focus, a:hover {color:#000;}+a {color:#009;text-decoration:underline;}+blockquote {margin:1.5em;color:#666;font-style:italic;}+strong {font-weight:bold;}+em, dfn {font-style:italic;}+dfn {font-weight:bold;}+sup, sub {line-height:0;}+abbr, acronym {border-bottom:1px dotted #666;}+address {margin:0 0 1.5em;font-style:italic;}+del {color:#666;}+pre, code {margin:1.5em 0;white-space:pre;}+pre, code, tt {font:1em 'andale mono', 'lucida console', monospace;line-height:1.5;}+li ul, li ol {margin:0 1.5em;}+ul, ol {margin:0 1.5em 1.5em 1.5em;}+ul {list-style-type:disc;}+ol {list-style-type:decimal;}+dl {margin:0 0 1.5em 0;}+dl dt {font-weight:bold;}+dd {margin-left:1.5em;}+table {margin-bottom:1.4em;width:100%;}+th {font-weight:bold;background:#C3D9FF;}+th, td {padding:4px 10px 4px 5px;}+tr.even td {background:#E5ECF9;}+tfoot {font-style:italic;}+caption {background:#eee;}+.small {font-size:.8em;margin-bottom:1.875em;line-height:1.875em;}+.large {font-size:1.2em;line-height:2.5em;margin-bottom:1.25em;}+.hide {display:none;}+.quiet {color:#666;}+.loud {color:#000;}+.highlight {background:#ff0;}+.added {background:#060;color:#fff;}+.removed {background:#900;color:#fff;}+.first {margin-left:0;padding-left:0;}+.last {margin-right:0;padding-right:0;}+.top {margin-top:0;padding-top:0;}+.bottom {margin-bottom:0;padding-bottom:0;}++/* grid.css */+.container {width:950px;margin:0 auto;}+.showgrid {background:url(src/grid.png);}+body {margin:1.5em 0;}+div.span-1, div.span-2, div.span-3, div.span-4, div.span-5, div.span-6, div.span-7, div.span-8, div.span-9, div.span-10, div.span-11, div.span-12, div.span-13, div.span-14, div.span-15, div.span-16, div.span-17, div.span-18, div.span-19, div.span-20, div.span-21, div.span-22, div.span-23, div.span-24 {float:left;margin-right:10px;}+div.last {margin-right:0;}+.span-1 {width:30px;}+.span-2 {width:70px;}+.span-3 {width:110px;}+.span-4 {width:150px;}+.span-5 {width:190px;}+.span-6 {width:230px;}+.span-7 {width:270px;}+.span-8 {width:310px;}+.span-9 {width:350px;}+.span-10 {width:390px;}+.span-11 {width:430px;}+.span-12 {width:470px;}+.span-13 {width:510px;}+.span-14 {width:550px;}+.span-15 {width:590px;}+.span-16 {width:630px;}+.span-17 {width:670px;}+.span-18 {width:710px;}+.span-19 {width:750px;}+.span-20 {width:790px;}+.span-21 {width:830px;}+.span-22 {width:870px;}+.span-23 {width:910px;}+.span-24, div.span-24 {width:950px;margin:0;}+.append-1 {padding-right:40px;}+.append-2 {padding-right:80px;}+.append-3 {padding-right:120px;}+.append-4 {padding-right:160px;}+.append-5 {padding-right:200px;}+.append-6 {padding-right:240px;}+.append-7 {padding-right:280px;}+.append-8 {padding-right:320px;}+.append-9 {padding-right:360px;}+.append-10 {padding-right:400px;}+.append-11 {padding-right:440px;}+.append-12 {padding-right:480px;}+.append-13 {padding-right:520px;}+.append-14 {padding-right:560px;}+.append-15 {padding-right:600px;}+.append-16 {padding-right:640px;}+.append-17 {padding-right:680px;}+.append-18 {padding-right:720px;}+.append-19 {padding-right:760px;}+.append-20 {padding-right:800px;}+.append-21 {padding-right:840px;}+.append-22 {padding-right:880px;}+.append-23 {padding-right:920px;}+.prepend-1 {padding-left:40px;}+.prepend-2 {padding-left:80px;}+.prepend-3 {padding-left:120px;}+.prepend-4 {padding-left:160px;}+.prepend-5 {padding-left:200px;}+.prepend-6 {padding-left:240px;}+.prepend-7 {padding-left:280px;}+.prepend-8 {padding-left:320px;}+.prepend-9 {padding-left:360px;}+.prepend-10 {padding-left:400px;}+.prepend-11 {padding-left:440px;}+.prepend-12 {padding-left:480px;}+.prepend-13 {padding-left:520px;}+.prepend-14 {padding-left:560px;}+.prepend-15 {padding-left:600px;}+.prepend-16 {padding-left:640px;}+.prepend-17 {padding-left:680px;}+.prepend-18 {padding-left:720px;}+.prepend-19 {padding-left:760px;}+.prepend-20 {padding-left:800px;}+.prepend-21 {padding-left:840px;}+.prepend-22 {padding-left:880px;}+.prepend-23 {padding-left:920px;}+div.border {padding-right:4px;margin-right:5px;border-right:1px solid #eee;}+div.colborder {padding-right:24px;margin-right:25px;border-right:1px solid #eee;}+.pull-1 {margin-left:-40px;}+.pull-2 {margin-left:-80px;}+.pull-3 {margin-left:-120px;}+.pull-4 {margin-left:-160px;}+.pull-5 {margin-left:-200px;}+.pull-6 {margin-left:-240px;}+.pull-7 {margin-left:-280px;}+.pull-8 {margin-left:-320px;}+.pull-9 {margin-left:-360px;}+.pull-10 {margin-left:-400px;}+.pull-11 {margin-left:-440px;}+.pull-12 {margin-left:-480px;}+.pull-13 {margin-left:-520px;}+.pull-14 {margin-left:-560px;}+.pull-15 {margin-left:-600px;}+.pull-16 {margin-left:-640px;}+.pull-17 {margin-left:-680px;}+.pull-18 {margin-left:-720px;}+.pull-19 {margin-left:-760px;}+.pull-20 {margin-left:-800px;}+.pull-21 {margin-left:-840px;}+.pull-22 {margin-left:-880px;}+.pull-23 {margin-left:-920px;}+.pull-24 {margin-left:-960px;}+.pull-1, .pull-2, .pull-3, .pull-4, .pull-5, .pull-6, .pull-7, .pull-8, .pull-9, .pull-10, .pull-11, .pull-12, .pull-13, .pull-14, .pull-15, .pull-16, .pull-17, .pull-18, .pull-19, .pull-20, .pull-21, .pull-22, .pull-23, .pull-24 {float:left;position:relative;}+.push-1 {margin:0 -40px 1.5em 40px;}+.push-2 {margin:0 -80px 1.5em 80px;}+.push-3 {margin:0 -120px 1.5em 120px;}+.push-4 {margin:0 -160px 1.5em 160px;}+.push-5 {margin:0 -200px 1.5em 200px;}+.push-6 {margin:0 -240px 1.5em 240px;}+.push-7 {margin:0 -280px 1.5em 280px;}+.push-8 {margin:0 -320px 1.5em 320px;}+.push-9 {margin:0 -360px 1.5em 360px;}+.push-10 {margin:0 -400px 1.5em 400px;}+.push-11 {margin:0 -440px 1.5em 440px;}+.push-12 {margin:0 -480px 1.5em 480px;}+.push-13 {margin:0 -520px 1.5em 520px;}+.push-14 {margin:0 -560px 1.5em 560px;}+.push-15 {margin:0 -600px 1.5em 600px;}+.push-16 {margin:0 -640px 1.5em 640px;}+.push-17 {margin:0 -680px 1.5em 680px;}+.push-18 {margin:0 -720px 1.5em 720px;}+.push-19 {margin:0 -760px 1.5em 760px;}+.push-20 {margin:0 -800px 1.5em 800px;}+.push-21 {margin:0 -840px 1.5em 840px;}+.push-22 {margin:0 -880px 1.5em 880px;}+.push-23 {margin:0 -920px 1.5em 920px;}+.push-24 {margin:0 -960px 1.5em 960px;}+.push-1, .push-2, .push-3, .push-4, .push-5, .push-6, .push-7, .push-8, .push-9, .push-10, .push-11, .push-12, .push-13, .push-14, .push-15, .push-16, .push-17, .push-18, .push-19, .push-20, .push-21, .push-22, .push-23, .push-24 {float:right;position:relative;}+.box {padding:1.5em;margin-bottom:1.5em;background:#E5ECF9;}+hr {background:#ddd;color:#ddd;clear:both;float:none;width:100%;height:.1em;margin:0 0 1.45em;border:none;}+hr.space {background:#fff;color:#fff;}+.clearfix:after, .container:after {content:".";display:block;height:0;clear:both;visibility:hidden;}+.clearfix, .container {display:inline-block;}+* html .clearfix, * html .container {height:1%;}+.clearfix, .container {display:block;}+.clear {clear:both;}++/* forms.css */+label {font-weight:bold;}+fieldset {padding:1.4em;margin:0 0 1.5em 0;border:1px solid #ccc;}+legend {font-weight:bold;font-size:1.2em;}+input.text, input.title, textarea, select {margin:0.5em 0;border:1px solid #bbb;}+input.text:focus, input.title:focus, textarea:focus, select:focus {border:1px solid #666;}+input.text, input.title {width:300px;padding:5px;}+input.title {font-size:1.5em;}+textarea {width:390px;height:250px;padding:5px;}+.error, .notice, .success {padding:.8em;margin-bottom:1em;border:2px solid #ddd;}+.error {background:#FBE3E4;color:#8a1f11;border-color:#FBC2C4;}+.notice {background:#FFF6BF;color:#514721;border-color:#FFD324;}+.success {background:#E6EFC2;color:#264409;border-color:#C6D880;}+.error a {color:#8a1f11;}+.notice a {color:#514721;}+.success a {color:#264409;}

@@ -0,0 +1,116 @@+<html>+  <head>+   <link rel="stylesheet" href="screen.css" type="text/css" media="screen, projection">+   <link rel="stylesheet" href="print.css" type="text/css" media="print">+   <!--[if IE]><link rel="stylesheet" href="ie.css" type="text/css" media="screen, projection"><![endif]-->++   <style type="text/css">+     #header {+       background-color:  #2A3B63;+       border-bottom: 4px solid #000014;+       margin-bottom: 2em;+     }++     #header h1 {+       padding-top: 0.4em;+       padding-left: 0.3em;+       font-family: "Helvetica";+       color:   #ddd;+     }++     body {+       background-color:  #717C8C;+     }++     #main {+       background-color:  #FFF7CB;+       font-family: "Ariel";+     }++     #body {+       margin-left: 0.3em;+     }++     #body pre {+       margin-left: 1em;+       color: #555;+     }++     #body form {+       margin-bottom: 1em;+     }++     #body p {+       font-size: 1.05em;+     }+   </style>+  </head>+  <body>+    <div class="container" id="main">+      <div class="span-24" id="header">+        <h1><tt>Network.MiniHTTP</tt> Test Page</h1>+      </div>++      <div class="span-24" id="body">+        <h3>Session support</h3>++        <p>Sessions, at the moment, are serialised, encrypted, signed and+        stored in cookies on the user's browser. In <tt>MiniHTTP</tt> they are+        availible as a Map with bytestrings as the keys and values.</p>++        <p>Here's the current value of your session:</p>+        <pre>{{SESSION:h}}</pre>++        <p>You can set a value using the following form:</p>++        <form method="POST" action="/setsession">+          <input name="name" value="" type="text"/>+          <input name="submit" value="Set name" type="submit"/>+        </form>++        <h3>Templating</h3>++        <p>Templating is up to the user, nothing is built into+        <tt>MiniHTTP</tt>, however this code is using <a+          href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/ctemplate-0.1"><tt>ctemplate</tt></a>,+        which is Google's internal templating system. It's pretty basic+        compared to other templating systems (which the reader may take to be+        a virtue or a deficiency), but it does escaping very well.</p>++        <p>The wrapper still needs a little efficiency work, but is currently+        functional (as you can see). Due to ctemplate being a C++ library, you+        appear to need to compile anything which uses it; <tt>ghci</tt> will+        fail in glibc.</p>++        <h3>OpenID</h3>++        <p>My initial test of the code was to write an <a+          href="http://www.openid.net">OpenID</a> consumer. This+        involves both server and client HTTP code. It's currently fairly+        functional, though incomplete. I only have an account with+        <a href="http://www.myopenid.com">MyOpenID.com</a>, so I've not tested it with anything else.</p>++        <p><i>For the moment, the input must be a valid URL. So don't forget+        the <tt>http://</tt> at the beginning.</i></p>++        <p>Once you have logged in, you should see your OpenID in the session+        output, above.</p>++        <form method="POST" action="/openidlogin">+          <input name="id" value="" type="text"/>+          <input name="submit" value="Login via OpenID" type="submit"/>+        </form>++        <h3>HTTPS support</h3>++        <p>Running an HTTPS server is as easy as running an HTTP server (as+        long as you have the certificate and private key in the correct+        format). However, it's been known to tickle a bug which causes the RTS+        to fall into an infinite loop.</p>++        <p>HTTPS client support is comming.</p>++      </div>+    </div>+  </body>+</html>

@@ -1,20 +0,0 @@--- | This is a very simple fileserver HTTP server which serves from the current---   directory. It will handle If-Modified-Since and Range requests etc. It---   doesn't do directory indexes yet, so GETting '/' will give a 404-module Main where--import Network.MiniHTTP.Server--main = serve 4112 $ do-  handleFromFilesystem "."-  handleConditionalRequest-  handleRangeRequests-  handleDecoration---- If you wanted to process some URLs differently, you would do something like:---   req <- getRequest---   if iWantToHandle $ reqUrl req---      then xyx---      else handleFromFilesystem "."---   handleConditionalRequest---   ...

@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Monad.State.Strict++import qualified Data.ByteString as B+import Data.ByteString.Char8 ()+import qualified Data.Map as Map++import Network.MiniHTTP.Server+import Network.MiniHTTP.Marshal+import Network.MiniHTTP.HTTPConnection+import Network.MiniHTTP.Session+import qualified Network.MiniHTTP.OpenID as OpenID+import qualified Network.MiniHTTP.Session as Session+import qualified Network.MiniHTTP.URL as URL+import qualified Text.CTemplate as T++import qualified OpenSSL as SSL++handleFromTemplate :: T.Dictionary -> WebMonad ()+handleFromTemplate tmpl = do+  Just r <- lift $ T.expand T.DontStrip tmpl+  source <- lift $ bsSource r+  setReply 200+  s <- get+  put $ s { wsSource = Just source }+  setHeader $ \h -> h { httpContentLength = Just $ fromIntegral $ B.length r }++index :: WebMonad ()+index = do+  session <- getSession+  handleFromTemplate $ T.Dictionary "example.tmpl" [("SESSION", T.StringV $ show session)]+  setHeader $ \h -> h { httpOtherHeaders = Map.fromList [("Cache-Control", "private")] }++setSession :: WebMonad ()+setSession = do+  postValues <- getPOST 1024+  setReply 301+  case Map.lookup "name" postValues of+       Nothing -> return ()+       Just name -> addSession "name" name+  setHeader $ \h -> h { httpLocation = Just "/" }++openIDLogin :: WebMonad ()+openIDLogin = do+  postValues <- getPOST 1024+  id <- Map.lookup "id" postValues+  let Just uri = URL.parse id+  discovery <- liftIO $ OpenID.discover uri+  (handle, _) <- liftIO $ OpenID.associate discovery+  setReply 302+  let url = OpenID.checkID OpenID.CheckIDSetup uri discovery handle "http://localhost.com/openidreturn" Nothing+  setHeader (\h -> h { httpLocation = Just $ URL.serialise url })++openIDReturn :: WebMonad ()+openIDReturn = do+  args <- getGET+  r <- liftIO $ OpenID.processCheckIDReply args+  case r of+       Left error -> errorPage error+       Right id -> do+         setReply 301+         addSession "openid" id+         setHeader $ \h -> h { httpLocation = Just "/" }++handleFile :: WebMonad ()+handleFile = do+  handleFromFilesystem "css/"+  handleConditionalRequest+  handleRangeRequests+  handleHandleToSource+  handleDecoration++main' :: IO ()+main' = serveHTTP 4112 $ dispatchOnURL+  [ (Exact "", index), (Exact "setsession", setSession)+  , (Exact "openidlogin", openIDLogin), (Exact "openidreturn", openIDReturn)+  , (Prefix "", handleFile)]++main :: IO ()+main = SSL.withOpenSSL main'

@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import qualified Data.ByteString.Lazy as BL+import           Data.String (fromString)++import qualified Network.Connection as C+import qualified Network.MiniHTTP.Client as Client+import qualified Network.MiniHTTP.URL as URL+import           Network.MiniHTTP.Marshal (emptyHeaders)+import           Network.MiniHTTP.HTTPConnection (sourceToLBS)++import           OpenSSL (withOpenSSL)++import System.Environment (getArgs)++main = withOpenSSL main'++main' = do+  args <- getArgs+  case args of+       [urlstring] -> do+         case URL.parse $ fromString urlstring of+              Nothing -> fail "Cannot parse URL"+              Just url -> do+                (conn, reply, msource) <- Client.fetchBasic emptyHeaders url+                print reply+                case msource of+                     Nothing -> C.close conn+                     Just source -> do+                       lbs <- sourceToLBS source+                       BL.putStr lbs+                       C.close conn+       _ -> fail "Please give a URL as the only argument"

@@ -1,18 +1,29 @@ name:            network-minihttp-version:         0.1+version:         0.2 license:         BSD3 license-file:    LICENSE author:          Adam Langley <agl@imperialviolet.org>-description:     A very minimal webserver-synopsis:        A very minimal webserver+description:     A ByteString based HTTP(S) library+synopsis:        A ByteString based library for writing HTTP(S) servers and clients.+homepage:        http://darcs.imperialviolet.org/network-minihttp category:        Network-build-depends:   base, containers, bytestring>=0.9, network-bytestring>=0.1.1.2, network>=2.1, stm>=2.1, binary>=0.4, binary-strict>=0.3, filepath>=1.1.0.0, mtl>=1.1.0.0, unix>=2.3.0.0, time>=1.1.2.0, old-locale>=1.0.0.0+build-depends:   base, containers, bytestring>=0.9, network-bytestring>=0.1.1.2, network>=2.1, stm>=2.1, binary>=0.4, binary-strict>=0.3, filepath>=1.1.0.0, mtl>=1.1.0.0, unix>=2.3.0.0, time>=1.1.2.0, old-locale>=1.0.0.0, HsOpenSSL>=0.4.1, network-connection>=0.1, network-dns>=0.1.2, tagsoup>=0.5 stability:       provisional tested-with:     GHC == 6.8.2 exposed-modules: Network.MiniHTTP.Server,-                 Network.MiniHTTP.Marshal-                 Network.MiniHTTP.MimeTypesParse-other-modules:   Network.MiniHTTP.Connection-extra-source-files: examples/fileserver.hs+                 Network.MiniHTTP.Marshal,+                 Network.MiniHTTP.Client,+                 Network.MiniHTTP.HTTPConnection,+                 Network.MiniHTTP.OpenID,+                 Network.MiniHTTP.Session,+                 Network.MiniHTTP.URL+other-modules:   Network.MiniHTTP.MimeTypesParse+extra-source-files: examples/test.hs,+                    examples/example.tmpl,+                    examples/css/screen.css,+                    examples/css/print.css,+                    examples/css/ie.css+                    examples/webcat.hs ghc-options:     -Wall -fno-warn-name-shadowing extensions:      OverloadedStrings+build-type: Simple