hails 0.9.0.1 → 0.9.2.0
raw patch · 20 files changed
+1146/−202 lines, 20 filesdep ~lio
Dependency ranges changed: lio
Files
- Hails/Data/Hson.hs +48/−12
- Hails/Database/Core.hs +1/−1
- Hails/Database/Query.hs +32/−35
- Hails/Database/Structured.hs +51/−20
- Hails/Database/TCB.hs +8/−5
- Hails/HttpServer.hs +8/−43
- Hails/HttpServer/Auth.hs +3/−2
- Hails/HttpServer/Types.hs +32/−1
- Hails/PolicyModule/DSL.hs +48/−55
- Hails/PolicyModule/Groups.hs +88/−0
- Hails/Web.hs +22/−0
- Hails/Web/Controller.hs +91/−0
- Hails/Web/Frank.hs +84/−0
- Hails/Web/REST.hs +151/−0
- Hails/Web/Responses.hs +131/−0
- Hails/Web/Router.hs +263/−0
- Hails/Web/User.hs +38/−0
- examples/simpleDBExample.hs +5/−4
- hails.cabal +11/−3
- hails.hs +31/−21
Hails/Data/Hson.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ConstraintKinds,+{-# LANGUAGE OverloadedStrings,+ ConstraintKinds, FlexibleContexts, DeriveDataTypeable, MultiParamTypeClasses,@@ -73,6 +74,7 @@ , isBsonDoc , hsonDocToBsonDoc , hsonDocToBsonDocStrict+ -- ** Converting labeled requests , labeledRequestToHson -- * Fields , FieldName, HsonField(..), BsonField(..)@@ -88,11 +90,11 @@ import Prelude hiding (lookup) import Control.Monad (liftM) import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Binary.Put import Data.Bson.Binary-import Data.Maybe (mapMaybe)-import Data.Monoid (mconcat)+import Data.Maybe (mapMaybe, fromJust, fromMaybe) import qualified Data.List as List import Data.Text (Text) import qualified Data.Text as T@@ -102,12 +104,17 @@ import Data.Functor.Identity (runIdentity) import qualified Data.Bson as Bson +import Data.Conduit (runResourceT, ($$))+import Data.Conduit.Binary (sourceLbs)+ import LIO import LIO.DCLabel import LIO.Labeled.TCB import LIO.TCB (ioTCB, ShowTCB(..)) -import Network.HTTP.Types+import Network.Wai.Parse ( FileInfo(..)+ , sinkRequestBody+ , lbsBackEnd) import Hails.Data.Hson.TCB import Hails.HttpServer.Types@@ -311,16 +318,45 @@ fail $ "hsonFieldToBsonField: field " ++ show n ++ " is PolicyLabeled" -labeledRequestToHson :: Label l => Labeled l Request -> LIO l (Labeled l HsonDocument)+-- | Convert a labeled request to a labeled document. Values of fields that+-- have a name that ends with @[]@ are converted to arrays and the+-- suffix @[]@ is stripped from the name.+labeledRequestToHson :: MonadDC m+ => DCLabeled Request -> m (DCLabeled HsonDocument) labeledRequestToHson lreq = do let origLabel = labelOf lreq- let req = unlabelTCB lreq- let body = mconcat . L8.toChunks $ requestBody req- let q = map convert $ parseSimpleQuery body- return $ labelTCB origLabel q- where convert (k,v) = HsonField- (T.pack . S8.unpack $ k)- (toHsonValue . S8.unpack $ v)+ req = unlabelTCB lreq+ btype = fromMaybe UrlEncoded $ getRequestBodyType req+ (ps, fs) <- liftLIO . ioTCB $ runResourceT $+ sourceLbs (requestBody req) $$ sinkRequestBody lbsBackEnd btype+ let psDoc = map convertPS ps+ fsDoc = map convertFS fs+ return $ labelTCB origLabel $ arrayify $ psDoc ++ fsDoc+ where convertPS (k,v) = HsonField+ (T.pack . S8.unpack $ k)+ (toHsonValue . S8.unpack $ v)+ convertFS (k,v) = HsonField (T.pack . S8.unpack $ k) + (toHsonValue $ fsToDoc v)+ fsToDoc f = [ "fileName" -: (T.pack . S8.unpack $ fileName f)+ , "fileContentType" -:+ (T.pack . S8.unpack $ fileContentType f)+ , "fileContent" -: (S8.concat . L.toChunks $ fileContent f)+ ] :: BsonDocument+ arrayify doc =+ let pred0 = (T.isSuffixOf "[]" . fieldName)+ (doc0, doc0_keep) = List.partition pred0 doc+ gs = List.groupBy (\x y -> fieldName x == fieldName y)+ . List.sortBy (\x y -> fieldName x `compare` fieldName y)+ $ doc0+ doc1 = concat $ map toArray gs+ in doc0_keep ++ doc1+ where toArray [] = []+ toArray ds = let n = fromJust+ . T.stripSuffix "[]"+ . fieldName+ . head $ ds+ vs = map (fromJust . fieldValue) ds+ in [ n -: BsonArray vs ] -- -- Friendly interface for creating documents
Hails/Database/Core.hs view
@@ -21,7 +21,7 @@ -- * Labeled documents , LabeledHsonDocument -- * Hails DB monad- , DBAction, DBActionState(..)+ , DBAction, DBActionState , MonadDB(..) , runDBAction, evalDBAction , getDatabase, getDatabaseP
Hails/Database/Query.hs view
@@ -72,7 +72,6 @@ import LIO import LIO.DCLabel-import LIO.DCLabel.Privs.TCB (allPrivTCB) import LIO.Labeled.TCB (unlabelTCB, labelTCB) import Hails.Data.Hson@@ -250,7 +249,7 @@ withCollection priv True cName $ \col -> do -- Already checked that we can write to DB and collection, -- apply policies:- ldoc <- liftLIO $ applyCollectionPolicyP priv col doc+ ldoc <- applyCollectionPolicyP priv col doc -- No IFC violation, perform insert: let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc _id `liftM` (execMongoActionTCB $ Mongo.insert cName bsonDoc)@@ -260,7 +259,7 @@ withCollection priv True cName $ \col -> do -- Already checked that we can write to DB and collection, -- apply policies:- ldoc <- liftLIO $ applyCollectionPolicyP priv col doc+ ldoc <- applyCollectionPolicyP priv col doc let _id_n = Text.pack "_id" case lookup _id_n doc of Nothing -> saveIt ldoc@@ -345,11 +344,11 @@ -- Already checked that we can write to DB and collection -- Document is labeled, remove label: let doc = unlabelTCB ldoc+ -- Check that labels are same as if we had applied them -- Apply policies to the unlabeled document, -- asserts that labeled values are below collection clearance:- ldocTCB <- liftLIO $ onExceptionP priv - (applyCollectionPolicyP allPrivTCB col doc)- (throwLIO PolicyViolation)+ dbPriv <- dbActionPriv `liftM` getActionStateTCB+ ldocTCB <- applyCollectionPolicyP dbPriv col doc -- Check that all the fields are the same (i.e., if there was a -- unlabeled PolicyLabeled value an this will fail): let same = compareDoc doc (unlabelTCB ldocTCB)@@ -439,7 +438,7 @@ -- | Same as 'next', but usess privileges when raising the current label. nextP :: DCPriv -> Cursor -> DBAction (Maybe LabeledHsonDocument) nextP p cur = do- -- Rause current label, can read from DB+collection:+ -- Raise current label, can read from DB+collection: taintP p $ curLabel cur -- Read the document: mMongoDoc <- execMongoActionTCB $ Mongo.next $ curInternal cur@@ -447,7 +446,8 @@ Nothing -> return Nothing Just mongoDoc -> do let doc0 = dataBsonDocToHsonDocTCB mongoDoc- ldoc <- liftLIO $ applyCollectionPolicyP allPrivTCB (curCollection cur) doc0+ dbPriv <- dbActionPriv `liftM` getActionStateTCB+ ldoc <- applyCollectionPolicyP dbPriv (curCollection cur) doc0 let doc = unlabelTCB ldoc l = labelOf ldoc proj = case curProject cur of@@ -552,38 +552,35 @@ -- Additionally, these labels must flow to the label of the collection -- clearance. (Of course, in both cases privileges are used to allow for -- more permissive flows.)-applyCollectionPolicyP :: DCPriv -- ^ Privileges+applyCollectionPolicyP :: MonadDC m+ => DCPriv -- ^ Privileges -> Collection -- ^ Collection and policies -> HsonDocument -- ^ Document to apply policies to- -> DC (LabeledHsonDocument)-applyCollectionPolicyP p col doc0 = do+ -> m (LabeledHsonDocument)+applyCollectionPolicyP p col doc0 = liftLIO $ do let doc1 = List.nubBy (\f1 f2 -> fieldName f1 == fieldName f2) doc0 typeCheckDocument fieldPolicies doc1- c <- getClearance- let colclr = colClearance col- -- Apply fied policies:- doc2 <- T.for doc1 $ \f@(HsonField n v) ->- case v of- (HsonValue _) -> return f- (HsonLabeled pl) -> do- -- NOTE: typeCheckDocument MUST be run before this:- let (FieldPolicy fieldPolicy) = fieldPolicies Map.! n- l = fieldPolicy doc1- case pl of- (NeedPolicyTCB bv) -> do- if l `canFlowTo` colclr then- let lbv = labelTCB l bv- in return (n -: hasPolicy lbv)- else throwLIO PolicyViolation- (HasPolicyTCB lbv) -> do- unless (labelOf lbv == l) $ throwLIO PolicyViolation- return f- -- Apply document policy:- let docLabel = docPolicy doc2- if docLabel `canFlowTo` colclr then- return $ labelTCB docLabel doc2- else throwLIO PolicyViolation+ withClearanceP p ((colClearance col) `lowerBound` c) $ do+ -- Apply fied policies:+ doc2 <- T.for doc1 $ \f@(HsonField n v) ->+ case v of+ (HsonValue _) -> return f+ (HsonLabeled pl) -> do+ -- NOTE: typeCheckDocument MUST be run before this:+ let (FieldPolicy fieldPolicy) = fieldPolicies Map.! n+ l = fieldPolicy doc1+ case pl of+ (NeedPolicyTCB bv) -> do+ lbv <- labelP p l bv `onException` throwLIO PolicyViolation+ return (n -: hasPolicy lbv)+ (HasPolicyTCB lbv) -> do+ unless (labelOf lbv == l) $ throwLIO PolicyViolation+ return f+ -- Apply document policy:+ clnow <- getClearance+ withClearanceP p (docPolicy doc2 `lub` clnow) $+ labelP p (docPolicy doc2) doc2 where docPolicy = documentLabelPolicy . colPolicy $ col fieldPolicies = fieldLabelPolicies . colPolicy $ col
Hails/Database/Structured.hs view
@@ -17,21 +17,22 @@ module Hails.Database.Structured ( DCRecord(..) , findAll, findAllP , DCLabeledRecord(..)+ , toLabeledDocument, fromLabeledDocument+ , toLabeledDocumentP, fromLabeledDocumentP ) where -import qualified Data.Map as Map import Data.Monoid (mappend) import Control.Monad (liftM)+import Control.Exception (SomeException) import LIO import LIO.DCLabel-import LIO.Privs.TCB (mintTCB) import Hails.Data.Hson import Hails.PolicyModule import Hails.Database.Core import Hails.Database.Query-+import Hails.Database.TCB -- | Class for converting from \"structured\" records to documents -- (and vice versa). Minimal definition consists of 'toDocument',@@ -126,7 +127,7 @@ case mldoc of Just ldoc -> do c <- getClearance- if canFlowToP p (labelOf ldoc) c+ if canFlowTo (labelOf ldoc) c then do md <- fromDocument `liftM` (liftLIO $ unlabelP p ldoc) cursorToRecords cur $ maybe docs (:docs) md else cursorToRecords cur docs@@ -138,7 +139,8 @@ -- allowed to create an instance of this class. Thus, we leverage the -- fact that the value constructor for a 'PolicyModule' is not exposed -- to untrusted code and require the policy module to create such a--- value in 'endorseInstance'.+-- value in 'endorseInstance'. The minimal implementation needs to+-- define 'endorseInstance'. class (PolicyModule pm, DCRecord a) => DCLabeledRecord pm a | a -> pm where -- | Insert a labeled record into the database. insertLabeledRecord :: MonadDB m => DCLabeled a -> m ObjectId@@ -163,42 +165,71 @@ -- --- insertLabeledRecord = insertLabeledRecordP noPriv+ insertLabeledRecord lrec = insertLabeledRecordP noPriv lrec --- saveLabeledRecord = saveLabeledRecordP noPriv+ saveLabeledRecord lrec = saveLabeledRecordP noPriv lrec -- insertLabeledRecordP p lrec = liftDB $ do let cName = recordCollection (forceType lrec)- ldoc <- liftLIO $ toDocumentP p lrec+ ldoc <- toLabeledDocumentP p lrec insertP p cName ldoc -- saveLabeledRecordP p lrec = liftDB $ do let cName = recordCollection (forceType lrec)- ldoc <- liftLIO $ toDocumentP p lrec+ ldoc <- toLabeledDocumentP p lrec saveP p cName ldoc +-- | Convert labeled record to labeled document.+toLabeledDocument :: (MonadDB m, DCLabeledRecord pm a)+ => DCLabeled a+ -> m (DCLabeled Document)+toLabeledDocument = toLabeledDocumentP noPriv -- | Uses the policy modules\'s privileges to convert a labeled record -- to a labeled document, if the policy module created an instance of -- 'DCLabeledRecord'.-toDocumentP :: (DCLabeledRecord pm a)- => DCPriv -- ^ Policy module privileges- -> DCLabeled a -- ^ Labeled record- -> DC (DCLabeled Document)-toDocumentP p' lr = do+toLabeledDocumentP :: (MonadDB m, DCLabeledRecord pm a)+ => DCPriv+ -> DCLabeled a -- ^ Labeled record+ -> m (DCLabeled Document)+toLabeledDocumentP p' lr = liftDB $ do+ pmPriv' <- dbActionPriv `liftM` getActionStateTCB -- Fail if not endorsed:- pmPriv <- getPMPrivTCB (endorseInstance lr)+ pmPriv <- liftLIO $ (evaluate . endorseInstance $ lr) >> return pmPriv'+ `catchLIO` (\(_ :: SomeException) -> return noPriv) let p = p' `mappend` pmPriv r <- unlabelP p lr lcur <- getLabel let lres = partDowngradeP p lcur (labelOf lr) labelP p lres $ toDocument r- where getPMPrivTCB pm = do- _ <- evaluate pm- let tn = policyModuleTypeName pm- f = mintTCB . dcPrivDesc . fst- return $ maybe noPriv f $ Map.lookup tn availablePolicyModules++-- | Convert labeled document to labeled record+fromLabeledDocument :: forall m pm a. (MonadDB m, DCLabeledRecord pm a)+ => DCLabeled Document+ -> m (DCLabeled a)+fromLabeledDocument = fromLabeledDocumentP noPriv++-- | Uses the policy modules\'s privileges to convert a labeled document+-- to a labeled record, if the policy module created an instance of+-- 'DCLabeledRecord'.+fromLabeledDocumentP :: forall m pm a. (MonadDB m, DCLabeledRecord pm a)+ => DCPriv+ -> DCLabeled Document+ -> m (DCLabeled a)+fromLabeledDocumentP p' ldoc = liftDB $ do+ pmPriv' <- dbActionPriv `liftM` getActionStateTCB+ -- Fail if not endorsed:+ pmPriv <- liftLIO $ (evaluate . endorseInstance $ fake) >> return pmPriv'+ `catchLIO` (\(_ :: SomeException) -> return noPriv)+ let p = p' `mappend` pmPriv+ doc <- unlabelP p ldoc+ lcur <- getLabel+ let lres = partDowngradeP p lcur (labelOf ldoc)+ rec <- fromDocument doc+ labelP p lres rec+ where fake :: DCLabeled a+ fake = undefined -- -- Misc helpers
Hails/Database/TCB.hs view
@@ -180,13 +180,15 @@ -- -- | The database system state threaded within a Hails computation.-data DBActionState = DBActionState {+data DBActionState = DBActionStateTCB { dbActionPipe :: Pipe -- ^ Pipe to underlying database system , dbActionMode :: AccessMode -- ^ Types of reads/write to perform , dbActionDB :: Database- -- ^ Current database executing computation against+ -- ^ Database computation is currently executing against+ , dbActionPriv :: DCPriv+ -- ^ Privilege of the policy module related to the DB } -- | A @DBAction@ is the monad within which database actions can be@@ -229,9 +231,10 @@ -> AccessMode -> DBActionState makeDBActionStateTCB priv dbName pipe mode = - DBActionState { dbActionPipe = pipe- , dbActionMode = mode- , dbActionDB = db }+ DBActionStateTCB { dbActionPipe = pipe+ , dbActionMode = mode+ , dbActionDB = db+ , dbActionPriv = priv } where db = DatabaseTCB { databaseName = dbName , databaseLabel = l , databaseCollections = labelTCB l Set.empty }
Hails/HttpServer.hs view
@@ -30,14 +30,9 @@ , sanitizeResp -- * Network types , module Network.HTTP.Types- -- * Converting labeled requests- , requestToDocument- , labeledRequestToLabeledDocument ) where import qualified Data.List as List-import Data.Text.Encoding (decodeUtf8)-import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Conduit@@ -54,20 +49,22 @@ import LIO import LIO.TCB import LIO.DCLabel-import LIO.DCLabel.Core (principalName) import LIO.DCLabel.Privs.TCB import LIO.Labeled.TCB import Hails.HttpServer.Auth import Hails.HttpServer.Types-import Hails.Data.Hson hiding (lookup) import System.IO+import Data.Time (getCurrentTime) --- | Convert a WAI 'W.Request' to a Hails 'Request' by consuming the body into--- a 'L.ByteString'.+-- | Convert a WAI 'W.Request' to a Hails 'Request' by consuming the+-- body into a 'L.ByteString'. The 'requestTime' is set to the+-- current time at the time this action is executed (which is when+-- the app is invoked). waiToHailsReq :: W.Request -> ResourceT IO Request waiToHailsReq req = do+ curTime <- liftIO getCurrentTime body <- fmap L.fromChunks $ W.requestBody req $$ consume return $ Request { requestMethod = W.requestMethod req , httpVersion = W.httpVersion req@@ -80,7 +77,8 @@ , remoteHost = W.remoteHost req , pathInfo = W.pathInfo req , queryString = W.queryString req- , requestBody = body }+ , requestBody = body + , requestTime = curTime } -- | Convert a Hails 'Response' to a WAI 'W.Response' hailsToWaiResponse :: Response -> W.Response@@ -202,39 +200,6 @@ paranoidDC' conf act = paranoidLIO act $ LIOState { lioLabel = dcPub , lioClearance = browserLabel conf}--------------- | Convert a labeled request to a labeled document-labeledRequestToLabeledDocument :: DCLabeled Request -> DCLabeled HsonDocument-labeledRequestToLabeledDocument lreq =- labelTCB (labelOf lreq) (requestToDocument . unlabelTCB $ lreq)---- | Convert a form post from a request into a document.--- Each field value is a 'BsonBlob', hence further \"casting\"--- may be necessary. Note that if a field with the same name is found,--- the values are grouped into a 'BsonArray'.-requestToDocument :: Request -> HsonDocument-requestToDocument req = groupFields $ List.map itemToField $ parseQuery body- where body = strictify $ requestBody req- --- itemToField (n, mv) = let nt = decodeUtf8 n- hv = maybe BsonNull (BsonBlob . Binary) mv- in nt -: hv- --- strictify = S.concat . L.toChunks- --- groupFields :: HsonDocument -> HsonDocument- groupFields xs =- let gs = List.groupBy (\x y -> fieldName x == fieldName y) xs- in List.concat $ List.map groupFunc gs- groupFunc xs = let n = fieldName . List.head $ xs- ys :: [BsonValue]- ys = List.map (\(HsonField _ (HsonValue x)) -> x) xs- in [n -: ys] --
Hails/HttpServer/Auth.hs view
@@ -79,8 +79,9 @@ let redirectTo = fromMaybe "/" $ do rawCookies <- lookup "Cookie" $ requestHeaders req0 lookup "redirect_to" $ parseCookies rawCookies- return $ responseLBS status200 [] (L8.pack $ show qry) -- [ ("Set-Cookie", cookie)- -- , ("Location", redirectTo)] ""+ return $ responseLBS status200 ([ ("Set-Cookie", cookie)+ , ("Location", redirectTo)])+ (L8.pack $ show qry) _ -> do let req = fromMaybe req0 $ do rawCookies <- lookup "Cookie" $ requestHeaders req0
Hails/HttpServer/Types.hs view
@@ -1,22 +1,30 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-} module Hails.HttpServer.Types ( -- * Requests Request(..)+ , getRequestBodyType, RequestBodyType(..) -- * Responses , Response(..) , addResponseHeader, removeResponseHeader -- * Applications and middleware , Application, RequestConfig(..)- , Middleware) where+ , Middleware+ ) where import qualified Data.List as List import Data.Text (Text) import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Network.Socket (SockAddr) import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as H+import Network.Wai.Parse (RequestBodyType(..)) +import Data.Time (UTCTime)+ import LIO.DCLabel --@@ -57,8 +65,31 @@ , queryString :: H.Query -- | Lazy ByteString containing the request body. , requestBody :: L.ByteString+ -- | Time request was received.+ , requestTime :: UTCTime } deriving Show +-- | Get the request body type (copied from @wai-extra@).+getRequestBodyType :: Request -> Maybe RequestBodyType+getRequestBodyType req = do+ ctype <- lookup "Content-Type" $ requestHeaders req+ if urlenc `S.isPrefixOf` ctype+ then Just UrlEncoded+ else case boundary ctype of+ Just x -> Just $ Multipart x+ Nothing -> Nothing+ where+ urlenc = S8.pack "application/x-www-form-urlencoded"+ formBound = S8.pack "multipart/form-data;"+ bound' = "boundary="+ boundary s =+ if "multipart/form-data;" `S.isPrefixOf` s+ then+ let s' = S.dropWhile (== 32) $ S.drop (S.length formBound) s+ in if bound' `S.isPrefixOf` s'+ then Just $ S.drop (S.length bound') s'+ else Nothing+ else Nothing -- -- Response
Hails/PolicyModule/DSL.hs view
@@ -21,35 +21,37 @@ user (or policy module) may read and modify the password. This policy is implemented below: -> data UsersPolicyModule = UsersPolicyModuleTCB DCPriv-> deriving Typeable-> -> instance PolicyModule UsersPolicyModule where-> initPolicyModule priv = do-> setPolicy priv $ do-> database $ do-> readers ==> anybody-> writers ==> anybody-> admins ==> this-> collection "users" $ do-> access $ do-> readers ==> anybody-> writers ==> anybody-> clearance $ do-> secrecy ==> this-> integrity ==> anybody-> document $ \doc -> do-> readers ==> anybody-> writers ==> anybody-> field "name" $ searchable-> field "password" $ labeled $ \doc -> do-> let user = "name" `at` doc :: String-> readers ==> this \/ user-> writers ==> this \/ user-> return $ UsersPolicyModuleTCB priv-> where this = privDesc priv+@+data UsersPolicyModule = UsersPolicyModuleTCB DCPriv+ deriving Typeable +instance PolicyModule UsersPolicyModule where+ 'initPolicyModule' priv = do+ 'setPolicy' priv $ do+ 'database' $ do+ 'readers' '==>' 'anybody'+ 'writers' '==>' 'anybody'+ 'admins' '==>' this+ 'collection' \"users\" $ do+ 'access' $ do+ 'readers' '==>' 'anybody'+ 'writers' '==>' 'anybody'+ 'clearance' $ do+ 'secrecy' '==>' this+ 'integrity' '==>' 'anybody'+ 'document' $ \doc -> do+ 'readers' '==>' 'anybody'+ 'writers' '==>' 'anybody'+ 'field' \"name\" $ 'searchable'+ 'field' \"password\" $ 'labeled' $ \doc -> do+ let user = \"name\" ``at`` doc :: String+ 'readers' '==>' this \\/ user+ 'writers' '==>' this \\/ user+ return $ UsersPolicyModuleTCB priv+ where this = 'privDesc' priv+@ + Notice that the database is public, as described above, but only this policy module may modify the internal collection names (as indicated by the 'admin' keyword). Similarly the collection is publicly@@ -129,7 +131,8 @@ integrity = Writers -- | Used when setting integrity component of the collection-set label, i.e.,--- the principals/administrators that can modify a database's underlying collections.+-- the principals/administrators that can modify a database's underlying+-- collections. data Admins = Admins instance Show Admins where show _ = "admins" @@ -420,16 +423,10 @@ (fN, cN) <- ask when (isJust s) $ fail $ "Collection " ++ show cN ++ " field " ++ show fN ++ " policy already specified."- case eval (act fN cN) fN cN of- Left e -> fail e- Right labFieldE -> put (Just labFieldE)- where act fN cN = do fpol (undefined :: HsonDocument)- s <- get- _ <- lookup' fN cN (show readers) s- _ <- lookup' fN cN (show writers) s- return . ColLabFieldExp $ - \doc -> fromRight $ eval (fpol' doc fN cN) fN cN- eval (ColLabFieldExpM e) fN cN =+ let labFieldE = ColLabFieldExp $ \doc ->+ fromRight $ eval (fpol' doc fN cN) fN cN+ put (Just labFieldE)+ where eval (ColLabFieldExpM e) fN cN = runReader (evalStateT (runErrorT e) Map.empty) (fN, cN) fpol' doc fN cN = do fpol doc s <- get@@ -577,7 +574,7 @@ -- > readers ==> anybody -- > writers ==> "Alice" \/ (("name" `at`doc) :: String) ----- states that every document in the collection is resable by anybody,+-- states that every document in the collection is readable by anybody, -- and only Alice or the principal named by the @name@ value in the -- document can modify or insert such data. document :: (HsonDocument -> ColDocExpM ()) -> ColExpM ()@@ -587,16 +584,10 @@ case Map.lookup "document" s of Just _ -> fail $ "Collection " ++ show cN ++ " document policy already specified."- _ -> case eval (act cN) cN of- Left e -> fail e- Right docT -> put (Map.insert "document" docT s)- where act cN = do fpol (undefined :: HsonDocument)- s <- get- _ <- lookup' cN (show readers) s- _ <- lookup' cN (show writers) s- return . ColDocT $ ColDocExp $ - \doc -> fromRight $ eval (fpol' doc cN) cN- eval (ColDocExpM e) cN =+ _ -> let docT = ColDocT $ ColDocExp $ \doc ->+ fromRight $ eval (fpol' doc cN) cN+ in put (Map.insert "document" docT s)+ where eval (ColDocExpM e) cN = runReader (evalStateT (runErrorT e) Map.empty) cN fpol' doc cN = do fpol doc s <- get@@ -712,7 +703,7 @@ setPolicy :: DCPriv -> PolicyExpM () -> PMAction () setPolicy priv pol = case runPolicy pol of- Left err -> throwLIO $ PolicyCompilerError err+ Left err -> throwLIO $ PolicyCompileError err Right policy -> execPolicy policy where execPolicy (PolicyExp db cs) = do execPolicyDB db @@ -738,16 +729,18 @@ unFieldExp ColFieldSearchable = SearchableField unFieldExp (ColLabFieldExp f) = FieldPolicy (unDataPolicy f) --- | Exception thrown if a policy cannot be compiled.-data PolicyCompilerError = PolicyCompilerError String+-- | Exception thrown if a policy cannot be \"compiled\" or if we+-- deternmine that it's faulty at \"runtime\".+data PolicySpecificiationError = PolicyCompileError String+ | PolicyRuntimeError String deriving (Show, Typeable) -instance Exception PolicyCompilerError +instance Exception PolicySpecificiationError -- -- Helpers -fromRight :: Either a b -> b+fromRight :: Either String b -> b fromRight (Right x) = x-fromRight _ = error "fromRight: unexpected value"+fromRight (Left e) = throw . PolicyRuntimeError $ e
+ Hails/PolicyModule/Groups.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{- | This module exports a class 'Groups' that policy modules+must define an instance of to define groups, or mappings+between a group 'Principal'and the principals in the group.++An app may then relabel a labeled value by using 'labelRewrite'.+++-}+module Hails.PolicyModule.Groups ( Groups(..)+ , labelRewrite ) where++import Data.Maybe+import qualified Data.List as List+import qualified Data.Map as Map++import Control.Monad++import LIO+import LIO.DCLabel++import Hails.Database+import Hails.Database.TCB (dbActionPriv, getActionStateTCB)+import Hails.PolicyModule+++class PolicyModule pm => Groups pm where+ -- | Typically, the action should expand a principal such as @#group@ to+ -- list of group members @[alice, bob]@.+ groups :: pm -- ^ Unused type-enforcing param+ -> DCPriv -- ^ Policy module privs+ -> Principal -- ^ Group+ -> DBAction [Principal] -- ^ (Policy module, group members)+ -- | Endorse the implementation of this instance. Note that this is+ -- reduced to WHNF to catch invalid instances that use 'undefined'.+ --+ -- Example implementation:+ --+ -- > groupsInstanceEndorse _ = MyPolicyModuleTCB {- Leave other values undefined -}+ groupsInstanceEndorse :: pm++-- | Given the policy module (which is used to invoke the right+-- 'groups' function) and labeled value, relabel the value according+-- to the 'Groups' of the policy module. Note that the first argument+-- may be bottom since it is solely used for typing purposes.+labelRewrite :: forall unused_pm a. Groups unused_pm+ => unused_pm+ -- ^ Policy module+ -> DCLabeled a+ -- ^ Label+ -> DBAction (DCLabeled a)+labelRewrite pm lx = do+ -- Make sure that 'groupsInstanceEndorse' is not bottom+ _ <- liftLIO $ evaluate (groupsInstanceEndorse :: unused_pm)+ -- Get underlying privileges if they corresponds to the named (by+ -- the first argument) policy module+ pmPriv <- getPMPriv+ -- Build map from principals to list of princpals+ pmap <- forM principals $ \p -> groups pm pmPriv p >>= \ps -> return (p, ps)+ -- Apply map to all principals in the label+ let lnew = dcLabel (mk pmap s) (mk pmap i)+ -- Relabel labeled value+ relabelLabeledP pmPriv lnew lx+ where getPMPriv = do+ pmPriv <- dbActionPriv `liftM` getActionStateTCB+ -- Make sure that the underlying policy module+ -- and one named in the first parameter are the same+ case Map.lookup (policyModuleTypeName pm) availablePolicyModules of+ Nothing -> return noPriv+ Just (p,_) -> return $ if toComponent p == privDesc pmPriv+ then pmPriv+ else noPriv+ -- Modify label by expanding principals according to the map+ mk pmap lc =+ let f = map (concatMap (\x -> fromJust $ List.lookup x pmap))+ in if lc == dcFalse+ then lc+ else fromList . f . toList $ lc+ -- Label components+ s = dcSecrecy $ labelOf lx+ i = dcIntegrity $ labelOf lx+ -- All unique principals in the labe+ principals = List.nub $ getPrincipals s ++ getPrincipals i+ -- Get principals form component+ getPrincipals lc = if lc == dcFalse+ then []+ else List.nub . concat . toList $ lc
+ Hails/Web.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}+{- |++This module re-exports the routing and controller modules.+See each module for their corresponding documentation.+ +Though you can implement a controller using the methods supplied by+this module (actually, "Hails.Web.Router"), we recommend using the+DSLs provided by "Hails.Web.Frank" or "Hails.Web.REST".++-}+module Hails.Web (+ module Hails.Web.Router+ , module Hails.Web.Responses+ , module Hails.Web.Controller+ , module Hails.Web.User+ ) where++import Hails.Web.Router+import Hails.Web.Responses+import Hails.Web.Controller+import Hails.Web.User
+ Hails/Web/Controller.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings+ , TypeSynonymInstances+ , FlexibleInstances+ , FlexibleInstances+ , MultiParamTypeClasses #-}++{- | +This module exports a definition of a 'Controller', which is simply a+'DC' action with the 'Labeled' HTTP 'Request' in the environment+(i.e., it is a 'Reader' monad).+-}++module Hails.Web.Controller+ ( Controller+ , request+ , requestHeader + , body+ , queryParam+ , respond+ , redirectBack+ , redirectBackOr + ) where++import LIO+import LIO.DCLabel++import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader++import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8++import Network.HTTP.Types.Header+import Hails.HttpServer+import Hails.Web.Router+import Hails.Web.Responses++data ControllerState = ControllerState { csRequest :: DCLabeled Request }++-- | A controller is simply a reader monad atop 'DC' with the 'Labeled'+-- 'Request' as the environment.+type Controller = ReaderT ControllerState DC++instance MonadLIO DCLabel Controller where+ liftLIO = lift++instance Routeable (Controller Response) where+ runRoute controller _ _ req = fmap Just $+ runReaderT controller $ ControllerState req++-- | Get the underlying request.+request :: Controller (DCLabeled Request)+request = fmap csRequest ask++-- | Get the query parameter mathing the supplied variable name.+queryParam :: S8.ByteString -> Controller (Maybe S8.ByteString)+queryParam varName = do+ req <- request >>= liftLIO . unlabel+ let qr = queryString req+ case lookup varName qr of+ Just n -> return n+ _ -> return Nothing++-- | Produce a response.+respond :: Routeable r => r -> Controller r+respond = return++-- | Extract the body in the request (after unlabeling it).+body :: Controller L8.ByteString+body = request >>= liftLIO . unlabel >>= return . requestBody++-- | Get a request header+requestHeader :: HeaderName -> Controller (Maybe S8.ByteString)+requestHeader name = do+ req <- request >>= liftLIO . unlabel+ return $ lookup name $ requestHeaders req++-- | Redirect back acording to the referer header. If the header is+-- not present redirect to root (i.e., @\/@).+redirectBack :: Controller Response+redirectBack = redirectBackOr (redirectTo "/")++-- | Redirect back acording to the referer header. If the header is+-- not present return the given response.+redirectBackOr :: Response -> Controller Response+redirectBackOr def = do+ mrefr <- requestHeader "referer"+ return $ case mrefr of+ Just refr -> redirectTo $ S8.unpack refr+ Nothing -> def
+ Hails/Web/Frank.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE Trustworthy #-}+{- |+Frank is a Sinatra-inspired DSL (see <http://www.sinatrarb.com>) for creating+routes. It is composable with all 'Routeable' types, but is designed to be used+with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a+URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for+details) and a 'Routeable':++@+module SimpleFrank (server) where+ +import "Data.String"+import "Data.Maybe"+import "Control.Monad"++import "LIO"+import "Hails.HttpServer.Types"+import "Hails.Web"+import qualified "Hails.Web.Frank" as F++server :: 'Application'+server = 'mkRouter' $ do+ F.'get' \"\/users\" $ do+ req \<- 'request' '>>=' unlabel+ return $ 'okHtml' $ 'fromString' $+ \"Welcome Home \" ++ (show $ 'serverName' req)+ F.'get' \"\/users\/:id\" $ do+ userId <- fromMaybe \"\" ``liftM`` 'queryParam' \"id\"+ return $ 'ok' \"text/json\" $ fromString $+ \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\"+ F.'put' \"\/user\/:id\" $ do+ ...+@++With @hails@, you can directly run this:++> hails --app=SimpleFrank++And, with @curl@, you can now checkout your page:++> $ curl localhost:8080/users+> Welcome Home "localhost"+>+> $ curl localhost:8080/users/123+> {"myid": "123"}+>+> $ ...++-}+module Hails.Web.Frank+ ( get+ , post+ , put+ , delete+ , options+ ) where++import Network.HTTP.Types+import Hails.Web.Router+import qualified Data.ByteString as S++-- | Helper method+frankMethod :: Routeable r => StdMethod -> S.ByteString -> r -> Route+frankMethod method pattern = routeMethod method . routePattern pattern++-- | Matches the GET method on the given URL pattern+get :: Routeable r => S.ByteString -> r -> Route+get = frankMethod GET++-- | Matches the POST method on the given URL pattern+post :: Routeable r => S.ByteString -> r -> Route+post = frankMethod POST++-- | Matches the PUT method on the given URL pattern+put :: Routeable r => S.ByteString -> r -> Route+put = frankMethod PUT++-- | Matches the DELETE method on the given URL pattern+delete :: Routeable r => S.ByteString -> r -> Route+delete = frankMethod DELETE++-- | Matches the OPTIONS method on the given URL pattern+options :: Routeable r => S.ByteString -> r -> Route+options = frankMethod OPTIONS
+ Hails/Web/REST.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{- |+REST is a DSL for creating routes using RESTful HTTP verbs.+See <http://en.wikipedia.org/wiki/Representational_state_transfer>++For example, an app handling users may define a REST controller as:++@+module SimpleREST (server) where+ +import "Data.String"+import "Data.Maybe"+import "Control.Monad"++import "LIO"+import "Hails.HttpServer.Types"+import "Hails.Web"+import qualified "Hails.Web.REST" as REST++server :: 'Application'+server = 'mkRouter' $ 'routeName' \"users\" $ do+ REST.'index' $ do+ req \<- 'request' '>>=' unlabel+ return $ 'okHtml' $ 'fromString' $+ \"Welcome Home \" ++ (show $ 'serverName' req)+ REST.'show' $ do+ userId <- fromMaybe \"\" ``liftM`` 'queryParam' \"id\"+ return $ 'ok' \"text/json\" $ fromString $+ \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\"+ ...+@++With @hails@, you can directly run this:++> hails --app=SimpleREST++And, with @curl@, you can now checkout your page:++> $ curl localhost:8080/users+> Welcome Home "localhost"+>+> $ curl localhost:8080/users/123+> {"myid": "123"}+>+> $ ...+++-}+module Hails.Web.REST+ ( RESTController+ , index, show, create, update, delete+ , edit, new+ ) where++import Prelude hiding (show, pi)++import LIO.DCLabel++import Control.Monad.Trans.State+import Hails.Web.Responses+import Hails.Web.Router+import Network.HTTP.Types++-- | Type used to encode a REST controller.+data RESTControllerState = RESTControllerState+ { restIndex :: Route+ , restShow :: Route+ , restCreate :: Route+ , restUpdate :: Route+ , restDelete :: Route+ , restEdit :: Route+ , restNew :: Route+ }++-- | Default state, returns @404@ for all verbs.+defaultRESTControllerState :: RESTControllerState+defaultRESTControllerState = RESTControllerState+ { restIndex = routeAll $ notFound+ , restShow = routeAll $ notFound+ , restCreate = routeAll $ notFound+ , restUpdate = routeAll $ notFound+ , restDelete = routeAll $ notFound+ , restEdit = routeAll $ notFound+ , restNew = routeAll $ notFound+ }++instance Routeable RESTControllerState where+ runRoute controller = runRoute $ do+ routeMethod GET $ do+ routeTop $ restIndex controller+ routeName "new" $ restNew controller+ routeVar "id" $ do+ routeTop $ restShow controller+ routeName "edit" $ restEdit controller++ routeMethod POST $ routeTop $ restCreate controller++ routeMethod PUT $ restUpdate controller++ routeMethod DELETE $ restDelete controller++-- | Monad used to encode a REST controller incrementally.+type RESTControllerM a = StateT RESTControllerState DC a++-- | Monad used to encode a REST controller incrementally.+-- The return type is not used, hence always '()'.+type RESTController = RESTControllerM ()++instance Routeable (RESTControllerM a) where+ runRoute controller = rt+ where rt pi conf req = do+ (_, st) <- runStateT controller defaultRESTControllerState+ runRoute st pi conf req+++-- |GET \/+index :: Routeable r => r -> RESTController+index route = modify $ \controller ->+ controller { restIndex = routeAll route }++-- |POST \/+create :: Routeable r => r -> RESTController+create route = modify $ \controller ->+ controller { restCreate = routeAll route }++-- |GET \/:id\/edit+edit :: Routeable r => r -> RESTController+edit route = modify $ \controller ->+ controller { restEdit = routeAll route }++-- |GET \/new+new :: Routeable r => r -> RESTController+new route = modify $ \controller ->+ controller { restNew = routeAll route }++-- |GET \/:id+show :: Routeable r => r -> RESTController+show route = modify $ \controller ->+ controller { restShow = routeAll route }++-- |PUT \/:id+update :: Routeable r => r -> RESTController+update route = modify $ \controller ->+ controller { restUpdate = routeAll route }++-- |DELETE \/:id+delete :: Routeable r => r -> RESTController+delete route = modify $ \controller ->+ controller { restDelete = routeAll route }+
+ Hails/Web/Responses.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+-- | This module defines some convenience functions for creating responses.+module Hails.Web.Responses+ ( ok, okHtml+ , movedTo, redirectTo+ , badRequest, requireBasicAuth, forbidden+ , notFound+ , serverError+ ) where++import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.HTTP.Types+import Hails.HttpServer++-- | Type alias for 'S8.ByteString'+type ContentType = S8.ByteString++-- | Creates a 200 (OK) 'Response' with the given content-type and resposne+-- body+ok :: ContentType -> L8.ByteString -> Response+ok contentType body =+ Response status200 [(hContentType, contentType)] body++-- | Helper to make responses with content-type \"text/html\"+mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response+mkHtmlResponse stat hdrs =+ Response stat ((hContentType, S8.pack "text/html"):hdrs)++-- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the+-- given resposne body+okHtml :: L8.ByteString -> Response+okHtml body =+ mkHtmlResponse status200 [] body++-- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to+-- that URL.+movedTo :: String -> Response+movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>301 Moved Permanently</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Moved Permanently</H1>\n\+ \<P>The document has moved <A HREF=\""+ , L8.pack url+ , L8.pack "\">here</A>\n\+ \</BODY></HTML>\n"]++-- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.+redirectTo :: String -> Response+redirectTo url = mkHtmlResponse status303 [(hLocation, S8.pack url)] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>303 See Other</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>See Other</H1>\n\+ \<P>The document has moved <A HREF=\""+ , L8.pack url+ , L8.pack "\">here</A>\n\+ \</BODY></HTML>\n"]++-- | Returns a 400 (Bad Request) 'Response'.+badRequest :: Response+badRequest = mkHtmlResponse status400 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>400 Bad Request</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Bad Request</H1>\n\+ \<P>Your request could not be understood.</P>\n\+ \</BODY></HTML>\n"]++-- | Returns a 401 (Authorization Required) 'Response' requiring basic+-- authentication in the given realm.+requireBasicAuth :: String -> Response+requireBasicAuth realm = mkHtmlResponse status401+ [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>401 Authorization Required</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Authorization Required</H1>\n\+ \</BODY></HTML>\n"]++-- | Returns a 403 (Forbidden) 'Response'.+forbidden :: Response+forbidden = mkHtmlResponse status403 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>403 Forbidden</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Forbidden</H1>\n\+ \<P>You don't have permission to access this page.</P>\n\+ \</BODY></HTML>\n"]++-- | Returns a 404 (Not Found) 'Response'.+notFound :: Response+notFound = mkHtmlResponse status404 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>404 Not Found</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Not Found</H1>\n\+ \<P>The requested URL was not found on this server.</P>\n\+ \</BODY></HTML>\n"]++-- | Returns a 500 (Server Error) 'Response'.+serverError :: Response+serverError= mkHtmlResponse status500 [] html+ where html = L8.concat+ [L8.pack+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\">\n\+ \<HTML><HEAD>\n\+ \<TITLE>500 Internal Server Error</TITLE>\n\+ \</HEAD><BODY>\n\+ \<H1>Internal Server Error</H1>\n\+ \</BODY></HTML>\n"]
+ Hails/Web/Router.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FlexibleInstances #-}+{- |++Conceptually, a route is function that, given an HTTP request, may return+an action (something that would return a response for the client if run).+Routes can be concatenated--where each route is evaluated until one+matches--and nested. Routes are expressed through the 'Routeable' type class.+'runRoute' transforms an instance of 'Routeable' to a function from 'Request'+to a monadic action (in the 'ResourceT' monad) that returns a+'Maybe' 'Response'. The return type was chosen to be monadic so routing+decisions can depend on side-effects (e.g. a random number or counter for A/B+testing, IP geolocation lookup etc').++-}++module Hails.Web.Router+ (+ -- * Example+ -- $Example+ Routeable(..)+ , mkRouter+ -- * Route Monad+ , Route, RouteM(..)+ -- * Common Routes+ , routeAll, routeHost, routeTop, routeMethod+ , routePattern, routeName, routeVar+ ) where++import Prelude hiding (pi)++import LIO+import LIO.DCLabel++import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Network.HTTP.Types+import Hails.HttpServer+import Hails.Web.Responses++-- | Route handler is a fucntion from the path info, request+-- configuration, and labeled request to a response.+type RouteHandler = [Text] -- ^ Path info+ -> RequestConfig -- ^ Request configuration+ -> DCLabeled Request -- ^ Labeled request+ -> DC (Maybe Response)++{- |+'Routeable' types can be converted into a route function using 'runRoute'.+If the route is matched it returns a 'Response', otherwise 'Nothing'.++In general, 'Routeable's are data-dependant (on the 'Request'), but don't have+to be. For example, 'Application' is an instance of 'Routeable' that always+returns a 'Response':++@+ instance Routeable Application where+ runRoute app req = app req >>= return . Just+@++-}+class Routeable r where+ -- | Run a route+ runRoute :: r -> RouteHandler++-- | Converts any 'Routeable' into an 'Application' that can be passed+-- directly to a WAI server.+mkRouter :: Routeable r => r -> Application+mkRouter route conf lreq = do+ req <- liftLIO $ unlabel lreq+ let pi = pathInfo req+ mapp <- runRoute route pi conf lreq+ case mapp of+ Just resp -> return resp+ Nothing -> return notFound+++instance Routeable Application where+ runRoute app _ conf req = fmap Just $ app conf req++instance Routeable Response where+ runRoute resp _ _ _ = return . Just $ resp++{- |+The 'RouteM' type is a basic instance of 'Routeable' that simply holds+the routing function and an arbitrary additional data parameter. In+most cases this paramter is simply '()', hence we have a synonym for+@'RouteM' '()'@ called 'Route'. The power is derived from the+instances of 'Monad' and 'Monoid', which allow the simple construction+of complex routing rules using either lists ('Monoid') or do-notation.+Moreover, because of it's simple type, any 'Routeable' can be used as+a 'Route' (using 'routeAll' or by applying it to 'runRoute'), making+it possible to leverage the monadic or monoid syntax for any+'Routeable'.++Commonly, route functions that construct a 'Route' only inspect the 'Request'+and other parameters. For example, 'routeHost' looks at the hostname:++@+ routeHost :: Routeable r => S.ByteString -> r -> Route+ routeHost host route = Route func ()+ where func req = if host == serverName req+ then runRoute route req+ else return Nothing+@++However, because the result of a route is in the+'ResourceT' monad, routes have all the power of an 'Application' and can make+state-dependant decisions. For example, it is trivial to implement a route that+succeeds for every other request (perhaps for A/B testing):++@+ routeEveryOther :: (Routeable r1, Routeable r2)+ => MVar Int -> r1 -> r2 -> Route+ routeEveryOther counter r1 r2 = Route func ()+ where func req = do+ i <- liftIO . modifyMVar $ \i ->+ let i' = i+1+ in return (i', i')+ if i `mod` 2 == 0+ then runRoute r1 req+ else runRoute r2 req+@++-}+data RouteM a = Route RouteHandler a++-- | Synonym for 'RouteM', the common case where the data parameter is '()'.+type Route = RouteM ()++-- | Create a route given the route handler.+mroute :: RouteHandler -> Route+mroute handler = Route handler ()++instance Monad RouteM where+ return a = Route (const . const . const $ return Nothing) a+ (Route rtA valA) >>= fn =+ let (Route rtB valB) = fn valA+ in Route (\pi conf req -> do+ resA <- rtA pi conf req+ case resA of+ Nothing -> rtB pi conf req+ Just _ -> return resA) valB++instance Monoid Route where+ mempty = mroute $ const . const . const $ return Nothing+ mappend (Route a _) (Route b _) = mroute $ \pi conf req -> do+ c <- a pi conf req+ case c of+ Nothing -> b pi conf req+ Just _ -> return c++instance Routeable (RouteM a) where+ runRoute (Route rtr _) pi conf req = rtr pi conf req++-- | A route that always matches (useful for converting a 'Routeable' into a+-- 'Route').+routeAll :: Routeable r => r -> Route+routeAll = mroute . runRoute++-- | Matches on the hostname from the 'Request'. The route only successeds on+-- exact matches.+routeHost :: Routeable r => S.ByteString -> r -> Route+routeHost host route = mroute $ \pi conf lreq -> do+ req <- unlabel lreq+ if host == serverName req+ then runRoute route pi conf lreq+ else return Nothing++-- | Matches if the path is empty. Note that this route checks that 'pathInfo'+-- is empty, so it works as expected when nested under namespaces or other+-- routes that pop the 'pathInfo' list.+routeTop :: Routeable r => r -> Route+routeTop route = mroute $ \pi conf lreq -> do+ if null pi || (T.null . head $ pi)+ then runRoute route pi conf lreq+ else return Nothing++-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')+routeMethod :: Routeable r => StdMethod -> r -> Route+routeMethod method route = mroute $ \pi conf lreq -> do+ req <- unlabel lreq+ if renderStdMethod method == requestMethod req then+ runRoute route pi conf lreq+ else return Nothing++-- | Routes the given URL pattern. Patterns can include+-- directories as well as variable patterns (prefixed with @:@) to be added+-- to 'queryString' (see 'routeVar')+--+-- * \/posts\/:id+--+-- * \/posts\/:id\/new+--+-- * \/:date\/posts\/:category\/new+--+routePattern :: Routeable r => S.ByteString -> r -> Route+routePattern pattern route =+ let patternParts = map T.unpack $ decodePathSegments pattern+ in foldr mkRoute (routeTop route) patternParts+ where mkRoute (':':varName) = routeVar (S8.pack varName)+ mkRoute varName = routeName (S8.pack varName)++-- | Matches if the first directory in the path matches the given 'ByteString'+routeName :: Routeable r => S.ByteString -> r -> Route+routeName name route = mroute $ \pi conf lreq -> do+ if (not . null $ pi) && S8.unpack name == (T.unpack . head $ pi)+ then runRoute route (tail pi) conf lreq+ else return Nothing++-- | Always matches if there is at least one directory in 'pathInfo' but and+-- adds a parameter to 'queryString' where the key is the supplied+-- variable name and the value is the directory consumed from the path.+routeVar :: Routeable r => S.ByteString -> r -> Route+routeVar varName route = mroute $ \pi conf lreq -> do+ if null pi+ then return Nothing+ else do lreqNext <- liftLIO $ lFmap lreq $ \req ->+ let varVal = S8.pack . T.unpack . head $ pi+ in req {queryString = (varName, Just varVal):(queryString req)}+ runRoute route (tail pi) conf lreqNext++{- $Example+ #example#++The most basic 'Routeable' types are 'Application' and 'Response'. Reaching+either of these types marks a termination in the routing lookup. This module+exposes a monadic type 'Route' which makes it easy to create routing logic+in a DSL-like fashion.++'Route's are concatenated using the '>>' operator (or using do-notation).+In the end, any 'Routeable', including a 'Route' is converted to an+'Application' and passed to the server using 'mkRouter':++@++ mainAction :: Application+ mainAction req = ...++ signinForm :: Application+ signinForm req = ...++ login :: Application+ login req = ...++ updateProfile :: Application+ updateProfile req = ...++ main :: IO ()+ main = runSettings defaultSettings $ mkRouter $ do+ routeTop mainAction+ routeName \"sessions\" $ do+ routeMethod GET signinForm+ routeMethod POST login+ routeMethod PUT $ routePattern \"users/:id\" updateProfile+ routeAll $ responseLBS status404 [] \"Are you in the right place?\"+@++-}+
+ Hails/Web/User.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE OverloadedStrings #-}+{-|++This module exports a type corresponding to user\'s in Hails+and some helper functions.++-}+module Hails.Web.User (+ UserName+ , getHailsUser+ , withUserOrDoAuth+ ) where+++import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T+import Data.Text (Text)+import Hails.Web.Controller+import Hails.HttpServer++-- | User name.+type UserName = Text++-- | Execute action with the current user's name. Otherwise, request+-- that the user authenticate.+withUserOrDoAuth :: (UserName -> Controller Response)+ -> Controller Response+withUserOrDoAuth act = getHailsUser >>= \muser ->+ maybe (return reqLogin) act muser+ where reqLogin = Response status200 [("X-Hails-Login", "Yes")] ""++-- | Get the current user.+getHailsUser :: Controller (Maybe UserName)+getHailsUser = do+ fmap (fmap (T.pack . S8.unpack)) $ requestHeader "x-hails-user"++
examples/simpleDBExample.hs view
@@ -43,8 +43,9 @@ writers ==> anybody field "name" $ searchable field "password" $ labeled $ \doc -> do- readers ==> this \/ ("name" `at` doc :: String)- writers ==> this \/ ("name" `at` doc :: String)+ let user = "name" `at` doc :: String+ readers ==> this \/ user+ writers ==> this \/ user return $ UsersPolicyModuleTCB priv where this = privDesc priv @@ -57,8 +58,8 @@ mkDBConfFile = do writeFile dbConfFile (unlines [show pm]) setEnv "DATABASE_CONFIG_FILE" dbConfFile False- where pm :: (String, String, String)- pm = (mkName (UsersPolicyModuleTCB undefined), "_users", "users_db")+ where pm :: (String, String)+ pm = (mkName (UsersPolicyModuleTCB undefined), "users_db") dbConfFile = "/tmp/hails_example_database.conf" mkName x = let tp = typeRepTyCon $ typeOf x
hails.cabal view
@@ -1,5 +1,5 @@ Name: hails-Version: 0.9.0.1+Version: 0.9.2.0 build-type: Simple License: GPL-2 License-File: LICENSE@@ -83,7 +83,7 @@ Source-repository head Type: git- Location: http://www.gitstar.com/scs/hails.git+ Location: ssh://anonymous@gitstar.com/scs/lio.git Library@@ -97,7 +97,7 @@ ,parsec >= 3.1.2 ,binary >= 0.5 ,time >= 1.2.0.5- ,lio >= 0.9.0.0+ ,lio >= 0.9.1.1 ,base64-bytestring >= 0.1 ,bson >= 0.2 ,mongoDB >= 1.3.0@@ -130,9 +130,17 @@ Hails.HttpServer.Types Hails.PolicyModule Hails.PolicyModule.DSL+ Hails.PolicyModule.Groups Hails.PolicyModule.TCB Hails.HttpClient Hails.Version+ Hails.Web+ Hails.Web.User+ Hails.Web.Controller+ Hails.Web.Frank+ Hails.Web.REST+ Hails.Web.Responses+ Hails.Web.Router Other-modules: Paths_hails
hails.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables, CPP #-} module Main (main) where import qualified Data.ByteString.Char8 as S8@@ -35,21 +35,26 @@ about :: String -> String-about prog = prog ++ " " ++ showVersion version ++ "\n\n\- \Simple tool for launching Hails apps. This tool can be used in \n\- \both development and production mode. It allows you configure the \n\- \environment your app runs in (e.g., the port number the Hails HTTP \n\- \server should listen on, the MongoDB server it should connect to, \n\- \etc.). In development mode (default), " ++ prog ++ " uses some default\n\- \settings (e.g., port 8080). In production, mode all configuration \n\- \settings must be specified. To simplify deployment, this tool \n\- \checks the program environment for configuration settings (e.g., \n\- \variable PORT is used for the port number), but you can override \n\- \these with arguments. See \'" ++ prog ++ " --help\' for a list of \n\- \configuration settings and corresponding environment variables. \n\n"- ++ prog ++ " dynamically loads your app requst handler. Hence, the \n\- \app name is the module name where your \'server\' function is \n\- \defined."+about prog = prog ++ " " ++ showVersion version ++ "\n\n" +++ concat [ "Simple tool for launching Hails apps. This tool can be used in\n"+ , "both development and production mode. It allows you configure the\n"+ , "environment your app runs in (e.g., the port number the Hails HTTP\n"+ , "server should listen on, the MongoDB server it should connect to,\n"+ , "etc.). In development mode (default), "+ , prog+ , " uses some default\n"+ , "settings (e.g., port 8080). In production, mode all configuration\n"+ , "settings must be specified. To simplify deployment, this tool\n"+ , "checks the program environment for configuration settings (e.g.,\n"+ , "variable PORT is used for the port number), but you can override\n"+ , "these with arguments. See \'"+ , prog+ , " --help\' for a list of \n"+ , "configuration settings and corresponding environment variables.\n\n"+ , prog+ , " dynamically loads your app requst handler. Hence, the\n"+ , "app name is the module name where your \'server\' function is\n"+ , "defined."] -- --@@ -85,20 +90,25 @@ -- | Given an application module name, load the main controller named -- @server@. loadApp :: Bool -- -XSafe ?- -> Maybe String -- -package-config+ -> Maybe FilePath -- -package-db -> String -- Application name -> IO Application-loadApp safe mpkgConf appName = runGhc (Just libdir) $ do+loadApp safe mpkgDb appName = runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags let dflags1 = if safe then dopt_set (dflags0 { safeHaskell = Sf_Safe }) Opt_PackageTrust else dflags0- dflags2 = case mpkgConf of+ dflags2 = case mpkgDb of+#if MIN_VERSION_base(4,6,0)+ Just pkgDb ->+ dflags1 { extraPkgConfs = (PkgConfFile pkgDb:)}+#else Just pkgConf -> dopt_unset (dflags1 { extraPkgConfs =- pkgConf : extraPkgConfs dflags1 })- Opt_ReadUserPackageConf+ pkgConf : extraPkgConfs dflags1 })+ Opt_ReadUserPackageConf+#endif _ -> dflags1 void $ setSessionDynFlags dflags2 target <- guessTarget appName Nothing