packages feed

Spock (empty) → 0.1.0.0

raw patch · 6 files changed

+516/−0 lines, 6 filesdep +aesondep +basedep +base64-bytestringsetup-changed

Dependencies added: aeson, base, base64-bytestring, bytestring, containers, crypto-api, cryptohash, directory, filepath, http-types, monad-control, mtl, old-locale, resource-pool, resourcet, scotty, stm, text, time, transformers, unordered-containers, wai, wai-extra, xsd

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Spock.cabal view
@@ -0,0 +1,24 @@+name:                Spock+version:             0.1.0.0+synopsis:            Another Haskell web toolkit based on scotty+description:         This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, database helper, authentication and the power of scotty+Homepage:            https://github.com/agrafix/Spock+Bug-reports:         https://github.com/agrafix/Spock/issues+license:             BSD3+author:              Alexander Thiemann <mail@agrafix.net>+maintainer:          mail@agrafix.net+copyright:           (c) 2013 Alexander Thiemann+category:            Web+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:  Web.Spock, Web.Spock.StaticMiddleware+  other-modules:       Web.Spock.SessionManager,+                       Web.Spock.Monad+  build-depends:       base >= 4 && < 5, scotty >= 0.5, wai, filepath, directory, http-types, text, containers, bytestring, mtl, wai-extra, resourcet, stm, crypto-api == 0.10.*, unordered-containers, old-locale, base64-bytestring, time, monad-control, transformers, cryptohash, xsd, aeson, resource-pool+  ghc-options: -fwarn-unused-imports++source-repository head+  type:     git+  location: git://github.com/agrafix/Spock.git
+ Web/Spock.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Spock+    ( -- * Spock's core functions, types and helpers+      spock, authed, runQuery, getState, Http.StdMethod(..), SpockM+    , authedUser, unauthCurrent+      -- * Reexports from scotty+    , middleware, get, post, put, delete, patch, addroute, matchAny, notFound+    , status, addHeader, setHeader, redirect+    , text, html, file, json, source, raw+    , raise, rescue, next+    )+where++import Web.Spock.SessionManager+import Web.Spock.Monad++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Resource+import Data.Pool+import Web.Scotty.Trans+import qualified Data.Text as T+import qualified Network.HTTP.Types as Http++type SpockM conn sess st a = ScottyT (WebStateM conn sess st) a++-- | Run a spock application using the warp server, a given db storageLayer and an initial state+spock :: Int -> StorageLayer conn -> st -> SpockM conn sess st () -> IO ()+spock port storageLayer initialState defs =+    do sessionMgr <- openSessionManager+       connectionPool <- createPool (sl_createConn storageLayer) (sl_closeConn storageLayer) 5 (60*5) 5+       let internalState =+               WebState+               { web_dbConn = connectionPool+               , web_sessionMgr = sessionMgr+               , web_state = initialState+               }+           runM m = runResourceT $ runReaderT (runWebStateM m) internalState+           runActionToIO = runM++       scottyT port runM runActionToIO defs++-- | After checking that a login was successfull, register the usersId+-- into the session and create a session cookie for later "authed" requests+-- to work properly+authedUser :: user -> (user -> sess) -> ActionT (WebStateM conn sess st) ()+authedUser user getSessionId =+    do mgr <- getSessMgr+       (sm_createCookieSession mgr) (getSessionId user)++-- | Destroy the current users session+unauthCurrent :: ActionT (WebStateM conn sess st) ()+unauthCurrent =+    do mgr <- getSessMgr+       mSess <- sm_sessionFromCookie mgr+       case mSess of+         Just sess -> liftIO $ (sm_deleteSession mgr) (sess_id sess)+         Nothing -> return ()++-- | Before the request is performed, you can check if the signed in user has permissions to+-- view the contents of the request. You may want to define a helper function that+-- proxies this function to not pass around loadUser and checkRights all the time+authed :: Http.StdMethod -> [T.Text] -> RoutePattern+       -> (conn -> sess -> IO (Maybe user))+       -> (conn -> user -> [T.Text] -> IO Bool)+       -> (user -> ActionT (WebStateM conn sess st) ())+       -> SpockM conn sess st ()+authed reqTy requiredRights route loadUser checkRights action =+    addroute reqTy route $+        do mgr <- getSessMgr+           mSess <- fmap sess_data <$> (sm_sessionFromCookie mgr)+           case mSess of+             Just sval ->+                 do mUser <- runQuery $ \conn -> loadUser conn sval+                    case mUser of+                      Just user ->+                          do isOk <- runQuery $ \conn -> checkRights conn user requiredRights+                             if isOk+                             then action user+                             else http403 "No rights to see this!"+                      Nothing -> http403 "Not logged in"+             Nothing -> http403 "Not logged in"+    where+      http403 msg =+          do status Http.status403+             text msg
+ Web/Spock/Monad.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Web.Spock.Monad where++import Web.Spock.SessionManager++import Control.Applicative+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.Resource+import Data.Pool+import Data.Time.Clock ( UTCTime(..) )+import Web.Scotty.Trans+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Text.XML.XSD.DateTime as XSD++data StorageLayer a+   = StorageLayer+   { sl_createConn :: IO a+   , sl_closeConn :: a -> IO ()+   }++data WebState conn sess st+   = WebState+   { web_dbConn :: Pool conn+   , web_sessionMgr :: SessionManager sess+   , web_state :: st+   }++newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a }+    deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st))++webM :: MonadTrans t => WebStateM conn sess st a -> t (WebStateM conn sess st) a+webM = lift++runQuery :: MonadTrans t => (conn -> IO a) -> t (WebStateM conn sess st) a+runQuery query =+    webM $+    do pool <- asks web_dbConn+       liftIO $ withResource pool query++getState :: MonadTrans t => t (WebStateM conn sess st) st+getState = webM $ asks web_state++getSessMgr :: MonadTrans t => t (WebStateM conn sess st) (SessionManager sess)+getSessMgr = webM $ asks web_sessionMgr++instance Parsable T.Text where+    parseParam = Right . TL.toStrict++instance Parsable BSL.ByteString where+    parseParam = Right . BSL.fromStrict . T.encodeUtf8 . TL.toStrict++instance Parsable UTCTime where+    parseParam p =+        case join $ fmap XSD.toUTCTime $ XSD.dateTime (TL.toStrict p) of+          Nothing -> Left $ TL.pack $ "Can't parse param (`" ++ show p ++ "`) as UTCTime!"+          Just x -> Right x++instance (Functor a, Monad a, Applicative a) => Applicative (ActionT a) where+    pure = return+    (<*>) = ap
+ Web/Spock/SessionManager.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE FlexibleContexts, DeriveGeneric, OverloadedStrings, DoAndIfThenElse, RankNTypes #-}+module Web.Spock.SessionManager+    ( openSessionManager+    , SessionId, Session(..), SessionManager(..)+    )+where++import Control.Arrow+import Control.Concurrent.STM+import Control.Monad.Trans+import Crypto.Random (newGenIO, genBytes, SystemRandom)+import Data.Time+import System.Locale+import Web.Scotty.Trans+import qualified Data.ByteString.Base64 as B64+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Network.Wai as Wai++type SessionId = T.Text+data Session a+    = Session+    { sess_id :: SessionId+    , sess_validUntil :: UTCTime+    , sess_data :: a+    }+type UserSessions a = TVar (HM.HashMap SessionId (Session a))++data SessionManager a+   = SessionManager+   { sm_loadSession :: SessionId -> IO (Maybe (Session a))+   , sm_sessionFromCookie :: MonadIO m => ActionT m (Maybe (Session a))+   , sm_createCookieSession :: MonadIO m => a -> ActionT m ()+   , sm_newSession :: a -> IO (Session a)+   , sm_deleteSession :: SessionId -> IO ()+   }++_COOKIE_NAME_ = "asession"++sessionTTL = 10 * 60 * 60+sessionIdEntropy = 12 :: Int++openSessionManager :: IO (SessionManager a)+openSessionManager =+    do cacheHM <- atomically $ newTVar HM.empty+       return $ SessionManager+                  { sm_loadSession = loadSessionImpl cacheHM+                  , sm_sessionFromCookie = sessionFromCookieImpl cacheHM+                  , sm_createCookieSession = createCookieSessionImpl cacheHM+                  , sm_newSession = newSessionImpl cacheHM+                  , sm_deleteSession = deleteSessionImpl cacheHM+                  }++createCookieSessionImpl :: MonadIO m+                        => UserSessions a+                        -> a+                        -> ActionT m ()+createCookieSessionImpl sessRef val =+    do sess <- liftIO $ newSessionImpl sessRef val+       let formattedExp = T.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" (sess_validUntil sess)+       setHeader "Set-Cookie" (TL.concat [ TL.fromStrict _COOKIE_NAME_+                                         , "="+                                         , TL.fromStrict (sess_id sess)+                                         , "; path=/; expires="+                                         , TL.fromStrict formattedExp+                                         , ";"+                                         ]+                              )++newSessionImpl :: UserSessions a+                -> a+                -> IO (Session a)+newSessionImpl sessionRef content =+    do sess <- createSession content+       atomically $ modifyTVar sessionRef (\hm -> HM.insert (sess_id sess) sess hm)+       return sess++sessionFromCookieImpl :: MonadIO m+                      => UserSessions a -> ActionT m (Maybe (Session a))+sessionFromCookieImpl sessionRef =+    do req <- request+       case lookup "cookie" (Wai.requestHeaders req) >>=+            lookup _COOKIE_NAME_ . parseCookies . T.decodeUtf8 of+         Just sid ->+             liftIO $ loadSessionImpl sessionRef sid+         Nothing ->+             return Nothing+    where+      parseCookies :: T.Text -> [(T.Text, T.Text)]+      parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words++      parseCookie = first T.init . T.breakOnEnd "="++loadSessionImpl :: UserSessions a+                -> SessionId+                -> IO (Maybe (Session a))+loadSessionImpl sessionRef sid =+    do sessHM <- atomically $ readTVar sessionRef+       now <- getCurrentTime+       case HM.lookup sid sessHM of+         Just sess ->+             do if addUTCTime sessionTTL (sess_validUntil sess) > now+                then return $ Just sess+                else do deleteSessionImpl sessionRef sid+                        return Nothing+         Nothing ->+             return Nothing++deleteSessionImpl :: UserSessions a+                  -> SessionId+                  -> IO ()+deleteSessionImpl sessionRef sid =+    do atomically $ modifyTVar sessionRef (\hm -> HM.delete sid hm)+       return ()++createSession :: a -> IO (Session a)+createSession content =+    do gen <- g+       sid <- case genBytes sessionIdEntropy gen of+                Left err -> fail $ show err+                Right (x, _) -> return $ T.decodeUtf8 $ B64.encode x+       now <- getCurrentTime+       let validUntil = addUTCTime sessionTTL now+       return (Session sid validUntil content)+    where+      g = newGenIO :: IO SystemRandom
+ Web/Spock/StaticMiddleware.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Serve static files, subject to a policy that can filter or+--   modify incoming URIs. The flow is:+--+--   incoming request URI ==> policies ==> exists? ==> respond+--+--   If any of the polices fail, or the file doesn't+--   exist, then the middleware gives up and calls the inner application.+--   If the file is found, the middleware chooses a content type based+--   on the file extension and returns the file contents as the response.+--   Stolen from:+--   https://github.com/xich/scotty/blob/master/Network/Wai/Middleware/Static.hs+module Web.Spock.StaticMiddleware+    ( -- * Middlewares+      static, staticPolicy+    , -- * Policies+      Policy, (<|>), (>->), policy, predicate+    , addBase, addSlash, contains, hasPrefix, hasSuffix, noDots, only+    , -- * Utilities+      tryPolicy+    ) where++import Control.Monad.Trans (liftIO)+import qualified Data.ByteString as B+import Data.List+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Monoid+import qualified Data.Text as T++import Network.HTTP.Types (status200)+import System.Directory (doesFileExist)+import qualified System.FilePath as FP++import Network.Wai++-- | Take an incoming URI and optionally modify or filter it.+--   The result will be treated as a filepath.+newtype Policy = Policy { tryPolicy :: String -> Maybe String -- ^ Run a policy+                        }++-- | Note:+--   'mempty' == @policy Just@ (the always accepting policy)+--   'mappend' == @>->@ (policy sequencing)+instance Monoid Policy where+    mempty = policy Just+    mappend p1 p2 = policy (maybe Nothing (tryPolicy p2) . tryPolicy p1)++-- | Lift a function into a 'Policy'+policy :: (String -> Maybe String) -> Policy+policy = Policy++-- | Lift a predicate into a 'Policy'+predicate :: (String -> Bool) -> Policy+predicate p = policy (\s -> if p s then Just s else Nothing)++-- | Sequence two policies. They are run from left to right. (Note: this is `mappend`)+infixr 5 >->+(>->) :: Policy -> Policy -> Policy+(>->) = mappend++-- | Choose between two policies. If the first fails, run the second.+infixr 4 <|>+(<|>) :: Policy -> Policy -> Policy+p1 <|> p2 = policy (\s -> maybe (tryPolicy p2 s) Just (tryPolicy p1 s))++-- | Add a base path to the URI+--+-- > staticPolicy (addBase "/home/user/files")+--+-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/foo\/bar\"+--+addBase :: String -> Policy+addBase b = policy (Just . (b FP.</>))++-- | Add an initial slash to to the URI, if not already present.+--+-- > staticPolicy addSlash+--+-- GET \"foo\/bar\" looks for \"\/foo\/bar\"+addSlash :: Policy+addSlash = policy slashOpt+    where slashOpt s@('/':_) = Just s+          slashOpt s         = Just ('/':s)++-- | Accept only URIs with given suffix+hasSuffix :: String -> Policy+hasSuffix suf = predicate (isSuffixOf suf)++-- | Accept only URIs with given prefix+hasPrefix :: String -> Policy+hasPrefix pre = predicate (isPrefixOf pre)++-- | Accept only URIs containing given string+contains :: String -> Policy+contains s = predicate (isInfixOf s)++-- | Reject URIs containing \"..\"+noDots :: Policy+noDots = predicate (not . isInfixOf "..")++-- | Use URI as the key to an association list, rejecting those not found.+-- The policy result is the matching value.+--+-- > staticPolicy (only [("foo/bar", "/home/user/files/bar")])+--+-- GET \"foo\/bar\" looks for \"\/home\/user\/files\/bar\"+-- GET \"baz\/bar\" doesn't match anything+--+only :: [(String,String)] -> Policy+only al = policy (flip lookup al)++-- | Serve static files out of the application root (current directory).+-- If file is found, it is streamed to the client and no further middleware is run.+static :: Middleware+static = staticPolicy mempty++-- | Serve static files subject to a 'Policy'+staticPolicy :: Policy -> Middleware+staticPolicy p app req =+    maybe (app req)+          (\fp -> do exists <- liftIO $ doesFileExist fp+                     if exists+                        then return $ ResponseFile status200+                                                   [("Content-Type", getMimeType fp)]+                                                   fp+                                                   Nothing+                        else app req)+          (tryPolicy p $ T.unpack $ T.intercalate "/" $ pathInfo req)++type Ascii = B.ByteString++getMimeType :: FilePath -> Ascii+getMimeType = go . extensions+    where go [] = defaultMimeType+          go (ext:exts) = fromMaybe (go exts) $ M.lookup ext defaultMimeTypes++extensions :: FilePath -> [String]+extensions [] = []+extensions fp = case dropWhile (/= '.') fp of+                    [] -> []+                    s -> let ext = tail s+                         in ext : extensions ext++defaultMimeType :: Ascii+defaultMimeType = "application/octet-stream"++-- This list taken from snap-core's Snap.Util.FileServe+defaultMimeTypes :: M.Map String Ascii+defaultMimeTypes = M.fromList [+  ( "asc"     , "text/plain"                        ),+  ( "asf"     , "video/x-ms-asf"                    ),+  ( "asx"     , "video/x-ms-asf"                    ),+  ( "avi"     , "video/x-msvideo"                   ),+  ( "bz2"     , "application/x-bzip"                ),+  ( "c"       , "text/plain"                        ),+  ( "class"   , "application/octet-stream"          ),+  ( "conf"    , "text/plain"                        ),+  ( "cpp"     , "text/plain"                        ),+  ( "css"     , "text/css"                          ),+  ( "cxx"     , "text/plain"                        ),+  ( "dtd"     , "text/xml"                          ),+  ( "dvi"     , "application/x-dvi"                 ),+  ( "gif"     , "image/gif"                         ),+  ( "gz"      , "application/x-gzip"                ),+  ( "hs"      , "text/plain"                        ),+  ( "htm"     , "text/html"                         ),+  ( "html"    , "text/html"                         ),+  ( "jar"     , "application/x-java-archive"        ),+  ( "jpeg"    , "image/jpeg"                        ),+  ( "jpg"     , "image/jpeg"                        ),+  ( "js"      , "text/javascript"                   ),+  ( "json"    , "application/json"                  ),+  ( "log"     , "text/plain"                        ),+  ( "m3u"     , "audio/x-mpegurl"                   ),+  ( "mov"     , "video/quicktime"                   ),+  ( "mp3"     , "audio/mpeg"                        ),+  ( "mpeg"    , "video/mpeg"                        ),+  ( "mpg"     , "video/mpeg"                        ),+  ( "ogg"     , "application/ogg"                   ),+  ( "pac"     , "application/x-ns-proxy-autoconfig" ),+  ( "pdf"     , "application/pdf"                   ),+  ( "png"     , "image/png"                         ),+  ( "ps"      , "application/postscript"            ),+  ( "qt"      , "video/quicktime"                   ),+  ( "sig"     , "application/pgp-signature"         ),+  ( "spl"     , "application/futuresplash"          ),+  ( "svg"     , "image/svg+xml"                     ),+  ( "swf"     , "application/x-shockwave-flash"     ),+  ( "tar"     , "application/x-tar"                 ),+  ( "tar.bz2" , "application/x-bzip-compressed-tar" ),+  ( "tar.gz"  , "application/x-tgz"                 ),+  ( "tbz"     , "application/x-bzip-compressed-tar" ),+  ( "text"    , "text/plain"                        ),+  ( "tgz"     , "application/x-tgz"                 ),+  ( "torrent" , "application/x-bittorrent"          ),+  ( "ttf"     , "application/x-font-truetype"       ),+  ( "txt"     , "text/plain"                        ),+  ( "wav"     , "audio/x-wav"                       ),+  ( "wax"     , "audio/x-ms-wax"                    ),+  ( "wma"     , "audio/x-ms-wma"                    ),+  ( "wmv"     , "video/x-ms-wmv"                    ),+  ( "xbm"     , "image/x-xbitmap"                   ),+  ( "xml"     , "text/xml"                          ),+  ( "xpm"     , "image/x-xpixmap"                   ),+  ( "xwd"     , "image/x-xwindowdump"               ),+  ( "zip"     , "application/zip"                   ) ]