diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Spock.cabal b/Spock.cabal new file mode 100644 --- /dev/null +++ b/Spock.cabal @@ -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 +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 diff --git a/Web/Spock.hs b/Web/Spock.hs new file mode 100644 --- /dev/null +++ b/Web/Spock.hs @@ -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 diff --git a/Web/Spock/Monad.hs b/Web/Spock/Monad.hs new file mode 100644 --- /dev/null +++ b/Web/Spock/Monad.hs @@ -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 diff --git a/Web/Spock/SessionManager.hs b/Web/Spock/SessionManager.hs new file mode 100644 --- /dev/null +++ b/Web/Spock/SessionManager.hs @@ -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 diff --git a/Web/Spock/StaticMiddleware.hs b/Web/Spock/StaticMiddleware.hs new file mode 100644 --- /dev/null +++ b/Web/Spock/StaticMiddleware.hs @@ -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" ) ]