├── .gitignore ├── Hails ├── Data │ ├── Hson.hs │ └── Hson │ │ └── TCB.hs ├── Database.hs ├── Database │ ├── Core.hs │ ├── Query.hs │ ├── Query │ │ └── TCB.hs │ ├── Structured.hs │ └── TCB.hs ├── HttpClient.hs ├── HttpServer.hs ├── HttpServer │ ├── Auth.hs │ └── Types.hs ├── PolicyModule.hs ├── PolicyModule │ ├── DSL.hs │ ├── Groups.hs │ └── TCB.hs ├── Version.hs ├── Web.hs └── Web │ ├── Controller.hs │ ├── Frank.hs │ ├── REST.hs │ ├── Responses.hs │ ├── Router.hs │ └── User.hs ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── SimpleApp.hs ├── SimpleFrank.hs ├── SimpleFullExample │ ├── SimpleApp.hs │ ├── SimpleApp2.hs │ ├── SimplePolicyModule.hs │ ├── database.conf │ └── static │ │ ├── fetch.html │ │ └── store.html ├── SimpleParams.hs ├── SimpleREST.hs ├── SimpleStatic │ ├── SimpleApp.hs │ └── static │ │ ├── css │ │ ├── lightbox.css │ │ └── screen.css │ │ ├── images │ │ ├── bg-checker.png │ │ ├── box.png │ │ ├── bullet.gif │ │ ├── close.png │ │ ├── donate.png │ │ ├── favicon.gif │ │ ├── loading.gif │ │ ├── next.png │ │ ├── nyc.jpg │ │ ├── paris.jpg │ │ ├── prev.png │ │ ├── sf.jpg │ │ ├── speech-bubbles.png │ │ ├── thumb.nyc.jpg │ │ ├── thumb.paris.jpg │ │ ├── thumb.sf.jpg │ │ ├── thumb.tokyo.jpg │ │ └── tokyo.jpg │ │ └── js │ │ ├── jquery-1.7.2.min.js │ │ ├── jquery-ui-1.8.18.custom.min.js │ │ ├── jquery.smooth-scroll.min.js │ │ └── lightbox.js ├── SimpleWithClient │ └── SimpleApp.hs ├── hails-rock │ ├── HailsRock.hs │ ├── HailsRock │ │ ├── MP.hs │ │ └── Views.hs │ ├── database.conf │ └── static │ │ ├── css │ │ ├── bootstrap-responsive.css │ │ ├── bootstrap-responsive.min.css │ │ ├── bootstrap.css │ │ └── bootstrap.min.css │ │ ├── img │ │ ├── glyphicons-halflings-white.png │ │ └── glyphicons-halflings.png │ │ └── js │ │ ├── application.js │ │ ├── bootstrap.js │ │ ├── bootstrap.min.js │ │ └── jquery-1.10.1.js ├── httpClientExample.hs └── simpleDBExample.hs ├── hails.cabal ├── hails.hs └── tests ├── AuthTests.hs ├── DatabaseTests.hs ├── Hails └── Data │ └── Hson │ └── Instances.hs ├── HsonTests.hs ├── HttpServerTests.hs └── Tests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.hi 2 | *.o 3 | *.swp 4 | *~ 5 | /Setup 6 | /dist 7 | /doc 8 | /ls 9 | /ps 10 | /tmp 11 | /cabal-dev 12 | /.cabal-sandbox 13 | /cabal.sandbox.config 14 | -------------------------------------------------------------------------------- /Hails/Data/Hson/TCB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | 4 | {- | 5 | 6 | 7 | This module exports the type for a Hails BSON document, 'HsonDoc'. A 8 | Hails document is akin to "Data.Bson"\'s documents, but differs in two 9 | ways. First, Hails restricts the number of types to a subset of BSON's 10 | (see 'BsonVal'). This restriction is primarily due to the fact that 11 | many of the BSON types are redundant and not used (at least within 12 | Hails). Second, Hails allows for documents to contain policy-labeled 13 | values. 14 | 15 | Policy labeled values ('PolicyLabeled') are permitted only at the 16 | \"top-level\" of a document. (This is primarily done to keep 17 | policy-specification simple and may change in the future.) 18 | Consequently to allow for nested documents and documents containing an 19 | array of values we separate top-level fields ('HsonField'), that may 20 | contain policy labeled values, from potentially-nested fields 21 | ('BsonField'). A top-level field 'HsonField' is thus either a 22 | 'BsonField' or a 'PolicyLabled' value. 23 | 24 | To keep the TCB compact, this module does not export the combinators 25 | used to create documents in a friendly fashion. See "Hails.Data.Hson" 26 | for the safe external API. 27 | 28 | 29 | /Credit:/ Much of this code is based on/reuses "Data.Bson". 30 | -} 31 | 32 | module Hails.Data.Hson.TCB ( 33 | -- * Documents 34 | HsonDocument, BsonDocument 35 | -- * Fields 36 | , FieldName, HsonField(..), BsonField(..) 37 | -- * Values 38 | , HsonValue(..), BsonValue(..) 39 | , PolicyLabeled(..), ObjectId(..), Binary(..), S8 40 | -- * Marshall to/from "Data.Bson" 41 | , hsonDocToDataBsonDocTCB 42 | , dataBsonDocToHsonDocTCB 43 | , bsonDocToDataBsonDocTCB 44 | , dataBsonValueToHsonValueTCB 45 | -- * Internal 46 | , add__hails_prefix 47 | ) where 48 | 49 | import Data.Text (Text) 50 | import qualified Data.Text as T 51 | import Data.Int (Int32, Int64) 52 | import Data.Time.Clock (UTCTime) 53 | import Data.Typeable 54 | import qualified Data.Bson as Bson 55 | import qualified Data.Bson.Binary as Bson 56 | import Data.Bson ( ObjectId(..) ) 57 | import qualified Data.ByteString.Char8 as S8 58 | import qualified Data.ByteString.Lazy as L 59 | import qualified Data.ByteString.Lazy.Char8 as L8 60 | import qualified Data.Binary.Put as Binary 61 | import qualified Data.Binary.Get as Binary 62 | 63 | import LIO.DCLabel 64 | import LIO.TCB 65 | 66 | -- | Strict ByeString 67 | type S8 = S8.ByteString 68 | 69 | 70 | 71 | 72 | -- 73 | -- Document 74 | -- 75 | 76 | -- | A top-level document containing 'HsonField's. 77 | type HsonDocument = [HsonField] 78 | 79 | -- | A (possibly top-)level document containing 'BsonField's. 80 | type BsonDocument = [BsonField] 81 | 82 | -- 83 | -- Fields 84 | -- 85 | 86 | -- | The name of a field. 87 | type FieldName = Text 88 | 89 | -- | A field containing a named 'BsonValue' 90 | data BsonField = BsonField !FieldName BsonValue 91 | deriving (Typeable, Eq, Ord) 92 | 93 | -- | A field containing a named 'HsonValue' 94 | data HsonField = HsonField !FieldName HsonValue 95 | deriving (Typeable, Eq, Ord) 96 | 97 | -- 98 | -- Values 99 | -- 100 | 101 | -- | A @BsonValue@ is a subset of BSON ("Data.Bson") values. Note that a 102 | -- @BsonValue@ cannot contain any labeled values; all labeled values 103 | -- occur in a document as 'HsonValue's. Correspondingly, @BsonValue@s 104 | -- may be arbitrarily nested. 105 | data BsonValue = BsonFloat Double 106 | -- ^ Float value 107 | | BsonString Text 108 | -- ^ String value 109 | | BsonDoc BsonDocument 110 | -- ^ Inner document 111 | | BsonArray [BsonValue] 112 | -- ^ List of values 113 | | BsonBlob Binary 114 | -- ^ Binary blob value 115 | | BsonObjId ObjectId 116 | -- ^ Object Id value 117 | | BsonBool Bool 118 | -- ^ Boolean value 119 | | BsonUTC UTCTime 120 | -- ^ Time stamp value 121 | | BsonNull 122 | -- ^ The @NULL@ value 123 | | BsonInt32 Int32 124 | -- ^ 32-bit integer 125 | | BsonInt64 Int64 126 | -- ^ 64-bit integer 127 | deriving (Typeable, Eq, Ord) 128 | 129 | -- | An @HsonValue@ is a top-level value that may either be a 130 | -- 'BsonValue' or a policy labeled value. The separation of values 131 | -- into 'BsonValue' and 'HsonValue' is solely due to the restriction 132 | -- that policy-labeled values may only occur at the top level and 133 | -- 'BsonValue's may be nested (e.g. using 'BsonArray' and 'BsonDoc'). 134 | data HsonValue = HsonValue BsonValue 135 | -- ^ Bson value 136 | | HsonLabeled PolicyLabeled 137 | -- ^ Policy labeled value 138 | deriving (Typeable, Eq, Ord) 139 | 140 | -- | A @PolicyLabeled@ value can be either an unlabeled value for which 141 | -- the policy needs to be applied (@NeedPolicyTCB@), or an already 142 | -- labeled value (@HasPolicyTCB@). @PolicyLabeled@ is a partially-opaque 143 | -- type; code should not be able to inspect the value of an unlabeleda 144 | -- value, but may inspect an already labeled value. 145 | data PolicyLabeled = NeedPolicyTCB BsonValue 146 | -- ^ Policy was not applied 147 | | HasPolicyTCB (DCLabeled BsonValue) 148 | -- ^ Policy applied 149 | deriving (Typeable) 150 | 151 | instance Eq PolicyLabeled where (==) _ _ = True 152 | instance Ord PolicyLabeled where (<=) _ _ = False 153 | instance Show PolicyLabeled where show _ = "PolicyLabeled" 154 | 155 | 156 | -- | Arbitrary binary blob 157 | newtype Binary = Binary { unBinary :: S8 } 158 | deriving (Typeable, Show, Read, Eq, Ord) 159 | 160 | 161 | -- 162 | -- Convert to "Data.Bson" 163 | -- 164 | 165 | -- | Convert 'HsonValue' to a "Data.Bson" @Value@. Note that 166 | -- 'PolicyLabeled' values are marshalled out as "Data.Bson" @UserDefined@ 167 | -- values. This means that the @UserDefined@ type is reserved and 168 | -- exposing it as a type in 'BsonValue' would potentially lead to leaks. 169 | -- Note that the label is /NOT/ serialized, only the value. Hence, 170 | -- after marshalling such that back it is important that a policy is 171 | -- applied to label the field. 172 | hsonToDataBsonTCB :: HsonValue -> Bson.Value 173 | hsonToDataBsonTCB (HsonValue b) = bsonToDataBsonTCB b 174 | hsonToDataBsonTCB (HsonLabeled (HasPolicyTCB (LabeledTCB _ lv))) = 175 | toUserDef . hsonDocToDataBsonDocTCB $ 176 | [ HsonField __hails_HsonLabeled_value $ 177 | HsonValue lv ] 178 | where toUserDef = Bson.UserDef 179 | . Bson.UserDefined 180 | . strictify 181 | . Binary.runPut 182 | . Bson.putDocument 183 | strictify = S8.concat . L.toChunks 184 | hsonToDataBsonTCB _ = 185 | error $ "hsonToDataBsonTCB: all policy labeled values" ++ 186 | " must have labeled values" 187 | 188 | -- | Convert 'BsonValue' to a "Data.Bson" @Value@. 189 | bsonToDataBsonTCB :: BsonValue -> Bson.Value 190 | bsonToDataBsonTCB bv = case bv of 191 | (BsonFloat d) -> Bson.Float d 192 | (BsonString t) -> Bson.String t 193 | (BsonDoc d) -> Bson.Doc $ bsonDocToDataBsonDocTCB d 194 | (BsonArray hs) -> Bson.Array $ bsonToDataBsonTCB `map` hs 195 | (BsonBlob b) -> Bson.Bin . Bson.Binary . unBinary $ b 196 | (BsonObjId oid) -> Bson.ObjId oid 197 | (BsonBool b) -> Bson.Bool b 198 | (BsonUTC t) -> Bson.UTC t 199 | BsonNull -> Bson.Null 200 | (BsonInt32 i) -> Bson.Int32 i 201 | (BsonInt64 i) -> Bson.Int64 i 202 | 203 | 204 | -- | Convert an 'HsonField' to a "Data.Bson" @Field@. 205 | hsonFieldToDataBsonFieldTCB :: HsonField -> Bson.Field 206 | hsonFieldToDataBsonFieldTCB (HsonField n v) = 207 | (Bson.:=) n (hsonToDataBsonTCB v) 208 | 209 | -- | Convert a top-level document (i.e., 'HsonDocument') to a "Data.Bson" 210 | -- @Document@. This is the primary marshall-out function. All 211 | -- 'PolicyLabeled' values are marshalled out as "Data.Bson" @UserDefined@ 212 | -- values. This means that the @UserDefined@ type is reserved and 213 | -- exposing it as a type in 'BsonValue' would potentially lead to 214 | -- vulnerabilities in which labeled values can be marshalled in from 215 | -- well-crafted ByteStrings. Moreover, untrusted code should not have 216 | -- access to this function; having such access would allow it to 217 | -- inspect the serialized labeled values and thus violate IFC. 218 | hsonDocToDataBsonDocTCB :: HsonDocument -> Bson.Document 219 | hsonDocToDataBsonDocTCB = map hsonFieldToDataBsonFieldTCB 220 | 221 | -- | Convert a 'BsonField' to a "Data.Bson" @Field@. 222 | bsonFieldToDataBsonFieldTCB :: BsonField -> Bson.Field 223 | bsonFieldToDataBsonFieldTCB (BsonField n v) = 224 | (Bson.:=) n (bsonToDataBsonTCB v) 225 | 226 | -- | Convert a 'BsonDocument' to a "Data.Bson" @Document@. 227 | bsonDocToDataBsonDocTCB :: BsonDocument -> Bson.Document 228 | bsonDocToDataBsonDocTCB = map bsonFieldToDataBsonFieldTCB 229 | 230 | 231 | -- 232 | -- Convert from "Data.Bson" 233 | -- 234 | 235 | -- | Convert a "Data.Bson" @Field@ to 'BsonField'. 236 | dataBsonFieldToBsonFieldTCB :: Bson.Field -> BsonField 237 | dataBsonFieldToBsonFieldTCB ((Bson.:=) n v) = BsonField n (dataBsonToBsonTCB v) 238 | 239 | -- | Convert a "Data.Bson" @Document@ to a 'BsonDocument'. 240 | dataBsonDocToBsonDocTCB :: Bson.Document -> BsonDocument 241 | dataBsonDocToBsonDocTCB = map dataBsonFieldToBsonFieldTCB 242 | 243 | -- | Convert "Data.Bson" @Value@ to a 'BsonValue'. 244 | dataBsonToBsonTCB :: Bson.Value -> BsonValue 245 | dataBsonToBsonTCB bv = case bv of 246 | (Bson.Float d) -> BsonFloat d 247 | (Bson.String t) -> BsonString t 248 | (Bson.Doc d) -> BsonDoc $ dataBsonDocToBsonDocTCB d 249 | (Bson.Array hs) -> BsonArray $ dataBsonToBsonTCB `map` hs 250 | (Bson.Bin (Bson.Binary b)) -> BsonBlob . Binary $ b 251 | (Bson.ObjId oid) -> BsonObjId oid 252 | (Bson.Bool b) -> BsonBool b 253 | (Bson.UTC t) -> BsonUTC t 254 | Bson.Null -> BsonNull 255 | (Bson.Int32 i) -> BsonInt32 i 256 | (Bson.Int64 i) -> BsonInt64 i 257 | _ -> error "dataBsonToBsonTCB: only support subset of BSON" 258 | 259 | 260 | -- | Convert "Data.Bson" @Document@ to a 'HsonDocument'. This is the 261 | -- top-level function that marshalls BSON documents to Hails 262 | -- documents. This function assumes that all documents have been 263 | -- marshalled out using 'hsonDocToDataBsonDocTCB'. Otherwise, the 264 | -- 'PolicyLabled' values that are created from the document may be 265 | -- forged. 266 | dataBsonDocToHsonDocTCB :: Bson.Document -> HsonDocument 267 | dataBsonDocToHsonDocTCB = 268 | map (\((Bson.:=) n bv) -> HsonField n $ dataBsonValueToHsonValueTCB bv) 269 | 270 | -- |Convert a "Data.Bson" @Value@ to a 'HsonValue'. See 271 | -- 'dataBsonDocToHsonDocTCB'. 272 | dataBsonValueToHsonValueTCB :: Bson.Value -> HsonValue 273 | dataBsonValueToHsonValueTCB bv = case bv of 274 | (Bson.UserDef (Bson.UserDefined b)) -> 275 | let bdoc = Binary.runGet Bson.getDocument (lazyfy b) 276 | in case maybePolicyLabeledTCB bdoc of 277 | Nothing -> error $ "dataBsonValueToHsonValueTCB: " 278 | ++ "Expected PolicyLabeled" 279 | Just lv -> HsonLabeled lv 280 | v -> HsonValue $ dataBsonToBsonTCB v 281 | where lazyfy x = L8.fromChunks [x] 282 | 283 | 284 | 285 | -- | Hails internal field name for a policy labeled value (label part) 286 | -- (name part). 287 | __hails_HsonLabeled_value :: FieldName 288 | __hails_HsonLabeled_value = add__hails_prefix $ T.pack "HsonLabeled_value" 289 | 290 | -- | Hails internal prefix that is used to serialized labeled values. 291 | add__hails_prefix :: FieldName -> FieldName 292 | add__hails_prefix t = T.pack "__hails_" `T.append` t 293 | 294 | 295 | -- | Convert a "Data.Bson" @Document@ to a policy labeled value. 296 | maybePolicyLabeledTCB :: Bson.Document -> Maybe PolicyLabeled 297 | maybePolicyLabeledTCB doc = do 298 | v <- Bson.look __hails_HsonLabeled_value doc 299 | return . NeedPolicyTCB $ dataBsonToBsonTCB v 300 | -------------------------------------------------------------------------------- /Hails/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | 3 | {- | 4 | 5 | This module exports the database interface used by apps and policy 6 | modules to carry out database queries. The Hails data model is similar 7 | to that of MongoDB. Below we highlight some similarities and 8 | difference. We refer the interested reader to the documentation in 9 | "Hails.PolicyModule" for more details on the role of labels in Hails. 10 | 11 | At the coarsest level code can execute database actions ('DBAction') 12 | against the 'Database' of a policy module using 'withPolicyModule'. 13 | Different from MongoDB's notion of a database, Hails databases have an 14 | associated 'Label' which is used to restrict who can access the 15 | database. 16 | 17 | Each 'Database' is composed of a set of 'Collection's. The existence 18 | of a collection is protected by a collection-set label, which is, 19 | intern, protected by the database label. A collection is an approach 20 | to organizing and grouping elements of the same model. For example, 21 | collection \"users\" may contain elements (documents) corresponding to 22 | users of the system. Each collection has a label, clearance, and 23 | associated collection policy. The label of a collection serves the 24 | same role as the database label, but at a finer grain: it protects who 25 | can read and write to the collection. The collection clearance is also 26 | a label, but its role is to set an upper bound on the sensitivity of 27 | data that is and can be stored in the collection. For example, the 28 | collection \"user\" may set a clearance such that the system\'s 29 | private keys cannot be stored in the collection (by accident or 30 | malice). The collection policy specifies how elements of the 31 | collection are to be labeled when retrieved from the database. 32 | 33 | The aforementioned elements of a collection are documents of type 34 | 'HsonDocument'. Documents are the basic storage units composed of a 35 | fields (of type 'HsonField'), which are effectively key-value pairs. 36 | The first part of the collection policy is to specify how such 37 | documents are labeled upon retrieval from the database. Namely, by 38 | providing a function from the document to a label. Keys, or field 39 | names, have type 'FieldName' while values have type 'HsonValue'. Hails 40 | values are a subset of MongoDB's BSON specification. The second part 41 | of the collection policy is used to specify if a field value is 42 | publicly-searchable (i.e., readable by anybody that can read from the 43 | collection) or labeled according to a function that may depend on the 44 | data contained within the document itself. Hence, different form 45 | MongoDB\'s documents, Hails documents are typically labeled and thus 46 | protect the potentially-sensitive data contained within. 47 | 48 | This module is analogous to "Database.MongoDB" and uses MongoDB as the 49 | backed. Since the interfaces are similar we recommend glancing at 50 | their documentation as well. 51 | 52 | -} 53 | 54 | module Hails.Database ( 55 | -- * Hails database monad 56 | DBAction, MonadDB(..) 57 | , withDBContext 58 | , withPolicyModule 59 | , getDatabase, getDatabaseP 60 | -- ** Exception thrown by failed database actions 61 | , DBError(..) 62 | -- * Database layers 63 | -- ** Database 64 | , DatabaseName 65 | , Database, databaseName, databaseLabel, databaseCollections 66 | -- ** Collection 67 | , CollectionName 68 | , CollectionSet 69 | , Collection, colName, colLabel, colClearance, colPolicy 70 | -- ** Policy errors 71 | , PolicyError(..) 72 | -- ** Documents 73 | , module Hails.Data.Hson 74 | , LabeledHsonDocument 75 | -- * Database queries 76 | -- ** Write (insert/save) 77 | , InsertLike(..) 78 | -- ** Read 79 | , find, findP 80 | , next, nextP 81 | , findOne, findOneP 82 | -- *** Cursor 83 | , Cursor, curLabel 84 | -- *** Selection 85 | , Select(..) 86 | , Selection(..) 87 | , Selector 88 | -- *** Query 89 | , Query(..) 90 | , QueryOption(..) 91 | , Limit 92 | , BatchSize 93 | , Order(..) 94 | -- ** Delete 95 | , delete, deleteP 96 | ) where 97 | 98 | import Hails.Data.Hson 99 | import Hails.Database.Core 100 | import Hails.Database.TCB 101 | import Hails.Database.Query 102 | import Hails.PolicyModule 103 | -------------------------------------------------------------------------------- /Hails/Database/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | 3 | {- | 4 | 5 | This module exports labeled documents and the databse monad 6 | ('DBAction'). The database monad is used by apps and policy modules to 7 | execute database actions against a policy module's databse (see 8 | "Hails.PolicyModule"). The Hails database model and interface is 9 | documented in "Hails.Database". 10 | 11 | -} 12 | 13 | module Hails.Database.Core ( 14 | -- * Collection 15 | CollectionName 16 | , CollectionSet 17 | , Collection, colName, colLabel, colClearance, colPolicy 18 | -- * Database 19 | , DatabaseName 20 | , Database, databaseName, databaseLabel, databaseCollections 21 | -- * Labeled documents 22 | , LabeledHsonDocument 23 | -- * Hails DB monad 24 | , DBAction, DBActionState 25 | , withDBContext 26 | , MonadDB(..) 27 | , runDBAction, evalDBAction 28 | , getDatabase, getDatabaseP 29 | -- ** Database system configuration 30 | , Pipe, AccessMode(..), master, slaveOk 31 | ) where 32 | 33 | import Data.Monoid 34 | import Control.Monad 35 | import Control.Monad.Trans.State 36 | 37 | import LIO 38 | import LIO.DCLabel 39 | import LIO.Error 40 | 41 | import Hails.Data.Hson 42 | import Hails.Database.TCB 43 | 44 | 45 | -- 46 | -- Labeled documents 47 | -- 48 | -- | A labeled 'HsonDocument'. 49 | type LabeledHsonDocument = DCLabeled HsonDocument 50 | 51 | -- 52 | -- DB monad 53 | -- 54 | 55 | -- | Execute a database action returning the final result and state. 56 | -- In general, code should instead use 'evalDBAction'. This function 57 | -- is primarily used by trusted code to initialize a policy module 58 | -- which may have modified the underlying database. 59 | runDBAction :: DBAction a -> DBActionState -> DC (a, DBActionState) 60 | runDBAction = runStateT . unDBAction 61 | 62 | -- | Execute a database action returning the final result. 63 | evalDBAction :: DBAction a -> DBActionState -> DC a 64 | evalDBAction a s = fst `liftM` runDBAction a s 65 | 66 | 67 | -- | Execute a database action with a "stack" context. 68 | withDBContext :: String -> DBAction a -> DBAction a 69 | withDBContext ctx (DBActionTCB act) = 70 | DBActionTCB . StateT $ \s -> 71 | withContext ctx $ runStateT act s 72 | 73 | -- | Get the underlying database. Must be able to read from the 74 | -- database as enforced by applying 'taint' to the database label. 75 | -- This is required because the database label protects the 76 | -- label on collections which can be projected given a 'Database' 77 | -- value. 78 | getDatabase :: DBAction Database 79 | getDatabase = getDatabaseP mempty 80 | 81 | -- | Same as 'getDatabase', but uses privileges when raising the 82 | -- current label. 83 | getDatabaseP :: DCPriv -> DBAction Database 84 | getDatabaseP p = withDBContext "getDatabaseP" $ do 85 | db <- dbActionDB `liftM` getActionStateTCB 86 | liftLIO $ taintP p (databaseLabel db) 87 | return db 88 | 89 | -- | Arbitrary monad that can perform database actions. 90 | class Monad m => MonadDB m where 91 | -- | Lift a database action into the database monad. 92 | liftDB :: DBAction a -> m a 93 | 94 | instance MonadDB DBAction where liftDB = id 95 | -------------------------------------------------------------------------------- /Hails/Database/Query/TCB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | 3 | {- | 4 | 5 | This module exports the trusted types and functions used by 6 | "Hails.Database.Query" when performing database queries. 7 | 8 | -} 9 | 10 | module Hails.Database.Query.TCB ( 11 | -- * Labeled cursor 12 | Cursor(..) 13 | ) where 14 | 15 | import LIO.DCLabel 16 | import Hails.Data.Hson 17 | import Hails.Database.TCB 18 | import qualified Database.MongoDB as Mongo 19 | 20 | -- | A labeled cursor. The cursor is labeled with the join of the 21 | -- database and collection it reads from. The collection policies 22 | -- are \"carried\" along since they are applied on-demand. 23 | data Cursor = CursorTCB { curLabel :: DCLabel 24 | -- ^ Cursor label 25 | , curInternal :: Mongo.Cursor 26 | -- ^ Internal MongoDB cursor 27 | , curProject :: [FieldName] 28 | -- ^ Projector from query. Used to remove 29 | -- fields after performing query. 30 | , curCollection:: Collection 31 | -- ^ Collection cursor is reading from 32 | } 33 | -------------------------------------------------------------------------------- /Hails/Database/Structured.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE FlexibleContexts, 3 | MultiParamTypeClasses, 4 | FunctionalDependencies, 5 | FlexibleInstances, 6 | ScopedTypeVariables, 7 | TypeSynonymInstances #-} 8 | 9 | {- | 10 | 11 | This module exports classes 'DCRecord' and 'DCLabeledRecord' that 12 | provide a way for Hails applications to interact with persistent data 13 | more easily. Specifically, it provides a way to work with Haskell 14 | types as opposed to \"unstructured\" 'Document's. 15 | 16 | -} 17 | module Hails.Database.Structured ( DCRecord(..) 18 | , findAll, findAllP 19 | , DCLabeledRecord(..) 20 | , toLabeledDocument, fromLabeledDocument 21 | , toLabeledDocumentP, fromLabeledDocumentP 22 | ) where 23 | 24 | import Data.Monoid (mappend, mempty) 25 | import Control.Monad (liftM) 26 | 27 | import LIO 28 | import LIO.DCLabel 29 | 30 | import Hails.Data.Hson 31 | import Hails.PolicyModule 32 | import Hails.Database.Core 33 | import Hails.Database.Query 34 | import Hails.Database.TCB 35 | 36 | -- | Class for converting from \"structured\" records to documents 37 | -- (and vice versa). Minimal definition consists of 'toDocument', 38 | -- 'fromDocument', and 'recordCollection'. All database operations 39 | -- performed on the collection defined by 'recordCollection'. 40 | class DCRecord a where 41 | -- | Convert a document to a record 42 | fromDocument :: Monad m => Document -> m a 43 | -- | Convert a record to a document 44 | toDocument :: a -> Document 45 | -- | Get the collection name for the record 46 | recordCollection :: a -> CollectionName 47 | -- | Find an object with matching value for the given key. If the 48 | -- object does not exist or cannot be read (its label is above the 49 | -- clearance), this returns 'Nothing'. 50 | findBy :: (BsonVal v, MonadDB m) 51 | => CollectionName -> FieldName -> v -> m (Maybe a) 52 | -- | Find an object with given query 53 | findWhere :: MonadDB m => Query -> m (Maybe a) 54 | -- | Insert a record into the database 55 | insertRecord :: MonadDB m => a -> m ObjectId 56 | -- | Update a record in the database 57 | saveRecord :: MonadDB m => a -> m () 58 | -- | Same as 'findBy', but uses privileges. 59 | findByP :: (BsonVal v, MonadDB m) 60 | => DCPriv -> CollectionName -> FieldName -> v -> m (Maybe a) 61 | -- | Same as 'findWhere', but uses privileges. 62 | findWhereP :: MonadDB m => DCPriv -> Query -> m (Maybe a) 63 | -- | Same as 'insertRecord', but uses privileges. 64 | insertRecordP :: MonadDB m => DCPriv -> a -> m ObjectId 65 | -- | Same as 'saveRecord', but uses privileges. 66 | saveRecordP :: MonadDB m => DCPriv -> a -> m () 67 | 68 | -- 69 | -- Default definitions 70 | -- 71 | 72 | -- 73 | findBy = findByP mempty 74 | -- 75 | findWhere = findWhereP mempty 76 | -- 77 | insertRecord = insertRecordP mempty 78 | -- 79 | saveRecord = saveRecordP mempty 80 | -- 81 | insertRecordP p r = liftDB $ do 82 | insertP p (recordCollection r) $ toDocument r 83 | -- 84 | saveRecordP p r = liftDB $ do 85 | saveP p (recordCollection r) $ toDocument r 86 | -- 87 | findByP p cName k v = 88 | findWhereP p (select [k -: v] cName) 89 | -- 90 | findWhereP p query = liftDB $ do 91 | mldoc <- findOneP p query 92 | c <- liftLIO $ getClearance 93 | case mldoc of 94 | Just ldoc | canFlowToP p (labelOf ldoc) c -> 95 | fromDocument `liftM` (liftLIO $ unlabelP p ldoc) 96 | _ -> return Nothing 97 | -- -- 98 | -- deleteByP p policy colName k v = 99 | -- deleteWhereP p policy (select [k =: v] colName) 100 | -- -- 101 | -- deleteWhereP p policy sel = do 102 | -- -- Find with only supplied privileges 103 | -- mdoc <- findWhereP p policy $ select (selector sel) (coll sel) 104 | -- -- User underlying privileges as well: 105 | -- p' <- getPrivileges 106 | -- res <- withDB policy $ deleteOneP (p' `mappend` p) sel 107 | -- case res of 108 | -- Right _ -> return mdoc 109 | -- _ -> return Nothing 110 | -- -- 111 | 112 | 113 | -- | Find all records that satisfy the query and can be read, subject 114 | -- to the current clearance. 115 | findAll :: (DCRecord a, MonadDB m) => Query -> m [a] 116 | findAll = findAllP mempty 117 | 118 | -- | Same as 'findAll', but uses privileges. 119 | findAllP :: (DCRecord a, MonadDB m) 120 | => DCPriv -> Query -> m [a] 121 | findAllP p query = liftDB $ do 122 | cursor <- findP p query 123 | cursorToRecords cursor [] 124 | where cursorToRecords cur docs = do 125 | mldoc <- nextP p cur 126 | case mldoc of 127 | Just ldoc -> do 128 | c <- liftLIO getClearance 129 | if canFlowTo (labelOf ldoc) c 130 | then do md <- fromDocument `liftM` (liftLIO $ unlabelP p ldoc) 131 | cursorToRecords cur $ maybe docs (:docs) md 132 | else cursorToRecords cur docs 133 | _ -> return $ reverse docs 134 | 135 | -- | Class used by a policy module to translate a labeled record to a 136 | -- labeled document. Since the insert and save functions use the 137 | -- policy module\'s privileges, only the policy module should be 138 | -- allowed to create an instance of this class. Thus, we leverage the 139 | -- fact that the value constructor for a 'PolicyModule' is not exposed 140 | -- to untrusted code and require the policy module to create such a 141 | -- value in 'endorseInstance'. The minimal implementation needs to 142 | -- define 'endorseInstance'. 143 | class (PolicyModule pm, DCRecord a) => DCLabeledRecord pm a | a -> pm where 144 | -- | Insert a labeled record into the database. 145 | insertLabeledRecord :: MonadDB m => DCLabeled a -> m ObjectId 146 | -- | Insert a labeled record into the database 147 | saveLabeledRecord :: MonadDB m => DCLabeled a -> m () 148 | 149 | -- | Same as 'insertLabeledRecord', but using explicit privileges. 150 | insertLabeledRecordP :: MonadDB m => DCPriv -> DCLabeled a -> m ObjectId 151 | -- | Same as 'saveLabeledRecord', but using explicit privileges. 152 | saveLabeledRecordP :: MonadDB m => DCPriv -> DCLabeled a -> m () 153 | 154 | -- | Endorse the implementation of this instance. Note that this is 155 | -- reduced to WHNF to catch invalid instances that use 'undefined'. 156 | -- 157 | -- Example implementation: 158 | -- 159 | -- > endorseInstance _ = MyPolicyModuleTCB {- May leave other values undefined -} 160 | endorseInstance :: DCLabeled a -> pm 161 | 162 | -- 163 | -- Default definitions for insert/save 164 | -- 165 | 166 | -- 167 | insertLabeledRecord lrec = insertLabeledRecordP mempty lrec 168 | -- 169 | saveLabeledRecord lrec = saveLabeledRecordP mempty lrec 170 | -- 171 | insertLabeledRecordP p lrec = liftDB $ do 172 | let cName = recordCollection (forceType lrec) 173 | ldoc <- toLabeledDocumentP p lrec 174 | insertP p cName ldoc 175 | 176 | -- 177 | saveLabeledRecordP p lrec = liftDB $ do 178 | let cName = recordCollection (forceType lrec) 179 | ldoc <- toLabeledDocumentP p lrec 180 | saveP p cName ldoc 181 | 182 | -- | Convert labeled record to labeled document. 183 | toLabeledDocument :: (MonadDB m, DCLabeledRecord pm a) 184 | => DCLabeled a 185 | -> m (DCLabeled Document) 186 | toLabeledDocument = toLabeledDocumentP mempty 187 | 188 | -- | Uses the policy modules\'s privileges to convert a labeled record 189 | -- to a labeled document, if the policy module created an instance of 190 | -- 'DCLabeledRecord'. 191 | toLabeledDocumentP :: (MonadDB m, DCLabeledRecord pm a) 192 | => DCPriv 193 | -> DCLabeled a -- ^ Labeled record 194 | -> m (DCLabeled Document) 195 | toLabeledDocumentP p' lr = liftDB $ do 196 | pmPriv' <- dbActionPriv `liftM` getActionStateTCB 197 | liftLIO $ do 198 | -- Fail if not endorsed: 199 | pmPriv <- (evaluate . endorseInstance $ lr) >> return pmPriv' 200 | `catch` (\(_ :: SomeException) -> return mempty) 201 | let p = p' `mappend` pmPriv 202 | scopeClearance $ do 203 | -- raise clearance: 204 | clr <- getClearance 205 | setClearanceP p $ clr `lub` (p %% True) 206 | -- 207 | r <- unlabelP p lr 208 | lcur <- getLabel 209 | let lres = downgradeP p lcur `lub` (labelOf lr) 210 | labelP p lres $ toDocument r 211 | 212 | -- | Convert labeled document to labeled record 213 | fromLabeledDocument :: forall m pm a. (MonadDB m, DCLabeledRecord pm a) 214 | => DCLabeled Document 215 | -> m (DCLabeled a) 216 | fromLabeledDocument = fromLabeledDocumentP mempty 217 | 218 | -- | Uses the policy modules\'s privileges to convert a labeled document 219 | -- to a labeled record, if the policy module created an instance of 220 | -- 'DCLabeledRecord'. 221 | fromLabeledDocumentP :: forall m pm a. (MonadDB m, DCLabeledRecord pm a) 222 | => DCPriv 223 | -> DCLabeled Document 224 | -> m (DCLabeled a) 225 | fromLabeledDocumentP p' ldoc = liftDB $ do 226 | pmPriv' <- dbActionPriv `liftM` getActionStateTCB 227 | -- Fail if not endorsed: 228 | pmPriv <- liftLIO $ (evaluate . endorseInstance $ fake) >> return pmPriv' 229 | `catch` (\(_ :: SomeException) -> return mempty) 230 | let p = p' `mappend` pmPriv 231 | liftLIO $ scopeClearance $ do 232 | -- raise clearance: 233 | clr <- getClearance 234 | setClearanceP p $ clr `lub` (p %% True) 235 | -- get at the document 236 | doc <- liftLIO $ unlabelP p ldoc 237 | lcur <- liftLIO $ getLabel 238 | let lres = downgradeP p lcur `lub` (labelOf ldoc) 239 | rec <- fromDocument doc 240 | labelP p lres rec 241 | where fake :: DCLabeled a 242 | fake = undefined 243 | 244 | -- 245 | -- Misc helpers 246 | -- 247 | 248 | -- | Get the type of a 'DCLabeled' value 249 | forceType :: DCLabeled a -> a 250 | forceType = undefined 251 | 252 | -------------------------------------------------------------------------------- /Hails/Database/TCB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, 3 | MultiParamTypeClasses, 4 | StandaloneDeriving, 5 | DeriveDataTypeable, 6 | TypeSynonymInstances #-} 7 | 8 | {- | 9 | 10 | This module exports the basic database types and constructors. 11 | See "Hails.Database" for a description of the Hails database system. 12 | 13 | -} 14 | 15 | module Hails.Database.TCB ( 16 | -- * Collection 17 | CollectionName 18 | , CollectionSet 19 | , Collection(..) 20 | , collectionTCB 21 | -- * Database 22 | , DatabaseName 23 | , Database(..) 24 | -- * Policies 25 | , CollectionPolicy(..) 26 | , FieldPolicy(..) 27 | -- * Hails DB monad 28 | , DBAction(..), DBActionState(..) 29 | , getActionStateTCB 30 | , putActionStateTCB 31 | , updateActionStateTCB 32 | , makeDBActionStateTCB 33 | , setDatabaseLabelTCB 34 | , setCollectionSetLabelTCB 35 | , associateCollectionTCB 36 | -- ** Database system configuration 37 | , Pipe, AccessMode(..), master, slaveOk 38 | -- ** Exception thrown by failed database actions 39 | , DBError(..) 40 | -- ** Lifting "Database.MongoDB" actions 41 | , execMongoActionTCB 42 | ) where 43 | 44 | import Data.Text (Text) 45 | import Data.Set (Set) 46 | import qualified Data.Set as Set 47 | import Data.Map (Map) 48 | import Data.Typeable 49 | 50 | import Control.Applicative 51 | import Control.Monad.Trans 52 | import Control.Monad.Trans.State 53 | import Control.Exception 54 | 55 | import qualified Database.MongoDB as Mongo 56 | import Database.MongoDB.Connection ( Pipe ) 57 | import Database.MongoDB.Query ( AccessMode(..) 58 | , master 59 | , slaveOk 60 | , Failure(..) 61 | ) 62 | 63 | import LIO 64 | import LIO.TCB 65 | import LIO.DCLabel 66 | 67 | import Hails.Data.Hson 68 | 69 | -- 70 | -- Collections 71 | -- 72 | 73 | -- | The name of a collection. 74 | type CollectionName = Text 75 | 76 | 77 | -- | A @Collection@ is a MongoDB collection name with an associated 78 | -- label, clearance and labeling policy. Access to the collection is 79 | -- restricted according to the collection label. Data inserted-to and 80 | -- retrieved-from the collection will be labeled according to the 81 | -- collection policy, with the guarantee that no data more sensitive than 82 | -- the collection clearance can be inserted into the collection. 83 | data Collection = CollectionTCB { colName :: CollectionName 84 | -- ^ Collection name 85 | , colLabel :: DCLabel 86 | -- ^ Collection label 87 | , colClearance :: DCLabel 88 | -- ^ Collection clearance 89 | , colPolicy :: CollectionPolicy 90 | -- ^ Collection labeling policies 91 | } 92 | 93 | instance Eq Collection where 94 | c1 == c2 = colName c1 == colName c2 95 | 96 | instance Ord Collection where 97 | c1 <= c2 = colName c1 <= colName c2 98 | 99 | -- | Create a 'Collection', ignoring any IFC restrictions. 100 | collectionTCB :: CollectionName -- ^ Collection name 101 | -> DCLabel -- ^ Collection label 102 | -> DCLabel -- ^ Collection clearance 103 | -> CollectionPolicy -- ^ Collection policy 104 | -> Collection 105 | collectionTCB n l c p = CollectionTCB { colName = n 106 | , colLabel = l 107 | , colClearance = c 108 | , colPolicy = p 109 | } 110 | 111 | -- 112 | -- Policies 113 | -- 114 | 115 | -- | A collection policy contains the policy for labeling documents 116 | -- ('documentLabelPolicy') at a coarse grained level, and a set of 117 | -- policies for labeling fields of a document ('fieldLabelPolicies'). 118 | -- 119 | -- Specific fields can be associated with a 'FieldPolicy', which 120 | -- allows the policy module to either: 121 | -- 122 | -- * Explicitly make a field publicly readable to anyone who can 123 | -- access the collection by declaring the field to be a 124 | -- 'SearchableField', or 125 | -- 126 | -- * Label a field given the full documnet (see 'FieldPolicy'). 127 | -- 128 | -- Fields that do not have an associated policy are (conceputally) 129 | -- labeled with the document label ('documentLabelPolicy'). 130 | -- Similarly, the labels on the label of a policy-labeled field is the 131 | -- document label created with 'documentLabelPolicy'. /Note:/ the 132 | -- label on 'SearchableField's is solely the collection label. 133 | data CollectionPolicy = CollectionPolicy { 134 | documentLabelPolicy :: HsonDocument -> DCLabel 135 | -- ^ The label on documents of the collection. 136 | , fieldLabelPolicies :: Map FieldName FieldPolicy 137 | -- ^ The policies associated with specific fields. 138 | } 139 | 140 | -- | A @FieldPolicy@ is a security policy associated with fields. 141 | -- 'SearchabelField' specifies that the field can be referenced in the 142 | -- selection clause of a @Query@, and therefore only the collection label 143 | -- protects such fields. Conversely, 'FieldPolicy' specifies a labeling 144 | -- policy for the field. 145 | data FieldPolicy = SearchableField 146 | -- ^ Unlabeled, searchable field. 147 | | FieldPolicy (HsonDocument -> DCLabel) 148 | -- ^ Policy labeled field. 149 | 150 | -- 151 | -- Databases 152 | -- 153 | 154 | 155 | -- | The name of a database. 156 | type DatabaseName = Text 157 | 158 | -- | A labeled 'Collection' set. 159 | type CollectionSet = DCLabeled (Set Collection) 160 | 161 | -- | A @Database@ is a MongoDB database with an associated label and set 162 | -- of collections. The label is used to restrict access to the database. 163 | -- Since collection policies are specified by policy modules, every 164 | -- collection must /always/ be associated with some database (and 165 | -- thereby, policy module); a policy module is /not/ allowed to create a 166 | -- collection (and specify policies on it) in an arbitrary database. We 167 | -- allow for the existance of a collection to be secrect, and thus 168 | -- protect the set of collections with a label. 169 | data Database = DatabaseTCB { databaseName :: DatabaseName 170 | -- ^ Database name 171 | , databaseLabel :: DCLabel 172 | -- ^ Label of database 173 | , databaseCollections :: CollectionSet 174 | -- ^ Collections associated with databsae 175 | } 176 | 177 | -- 178 | -- DB monad 179 | -- 180 | 181 | -- | The database system state threaded within a Hails computation. 182 | data DBActionState = DBActionStateTCB { 183 | dbActionPipe :: Pipe 184 | -- ^ Pipe to underlying database system 185 | , dbActionMode :: AccessMode 186 | -- ^ Types of reads/write to perform 187 | , dbActionDB :: Database 188 | -- ^ Database computation is currently executing against 189 | , dbActionPriv :: DCPriv 190 | -- ^ Privilege of the policy module related to the DB 191 | } 192 | 193 | -- | A @DBAction@ is the monad within which database actions can be 194 | -- executed, and policy modules are defined. The monad is simply a 195 | -- state monad with 'DC' as monad as the underlying monad with access to 196 | -- a database system configuration ('Pipe', 'AccessMode', and 197 | -- 'Database'). The value constructor is part of the @TCB@ as to 198 | -- disallow untrusted code from modifying the access mode. 199 | newtype DBAction a = DBActionTCB { unDBAction :: StateT DBActionState DC a } 200 | deriving (Monad, Functor, Applicative) 201 | 202 | -- | Get the underlying state. 203 | getActionStateTCB :: DBAction DBActionState 204 | getActionStateTCB = DBActionTCB get 205 | 206 | -- | Get the underlying state. 207 | putActionStateTCB :: DBActionState -> DBAction () 208 | putActionStateTCB = DBActionTCB . put 209 | 210 | -- | Update the underlying state using the supplied function. 211 | updateActionStateTCB :: (DBActionState -> DBActionState) -> DBAction () 212 | updateActionStateTCB f = do 213 | s <- getActionStateTCB 214 | putActionStateTCB $ f s 215 | 216 | instance MonadLIO DCLabel DBAction where 217 | liftLIO = DBActionTCB . lift 218 | 219 | -- | Given a policy module's privileges, database name, pipe and access 220 | -- mode create the initial state for a 'DBAction'. The underlying 221 | -- database is labeled with the supplied privileges: both components of 222 | -- the label (secrecy and integrity) are set to the privilege 223 | -- description. In other words, only code that owns the policy module's 224 | -- privileges can modify the database configuration. Policy modules can 225 | -- use 'setDatabaseLabelP' to change the label of their database, and 226 | -- 'setCollectionMapLabelP' to change the label of the collection map. 227 | makeDBActionStateTCB :: DCPriv 228 | -> DatabaseName 229 | -> Pipe 230 | -> AccessMode 231 | -> DBActionState 232 | makeDBActionStateTCB priv dbName pipe mode = 233 | DBActionStateTCB { dbActionPipe = pipe 234 | , dbActionMode = mode 235 | , dbActionDB = db 236 | , dbActionPriv = priv } 237 | where db = DatabaseTCB { databaseName = dbName 238 | , databaseLabel = l 239 | , databaseCollections = LabeledTCB l Set.empty } 240 | l = prin %% prin 241 | prin = privDesc priv 242 | 243 | -- | Set the label of the underlying database to the supplied label, 244 | -- ignoring IFC. 245 | setDatabaseLabelTCB :: DCLabel -> DBAction () 246 | setDatabaseLabelTCB l = updateActionStateTCB $ \s -> 247 | let db = dbActionDB s 248 | in s { dbActionDB = db { databaseLabel = l } } 249 | 250 | -- | Set the label of the underlying database to the supplied label, 251 | -- ignoring IFC. 252 | setCollectionSetLabelTCB :: DCLabel -> DBAction () 253 | setCollectionSetLabelTCB l = updateActionStateTCB $ \s -> 254 | let db = dbActionDB s 255 | (LabeledTCB _ cs) = databaseCollections db 256 | cs' = LabeledTCB l $! cs 257 | in s { dbActionDB = db { databaseCollections = cs' } } 258 | 259 | -- | Associate a collection with underlying database, ignoring IFC. 260 | associateCollectionTCB :: Collection -- ^ New collection 261 | -> DBAction () 262 | associateCollectionTCB col = updateActionStateTCB $ \s -> 263 | let db = dbActionDB s 264 | in s { dbActionDB = doUpdate db } 265 | where doUpdate db = 266 | let (LabeledTCB l cs) = databaseCollections db 267 | in db { databaseCollections = LabeledTCB l $ 268 | Set.insert col cs } 269 | 270 | -- | Lift a mongoDB action into the 'DBAction' monad. This function 271 | -- always executes the action with "Database.MongoDB"\'s @access@. If 272 | -- the database action fails an exception of type 'Failure' is thrown. 273 | execMongoActionTCB :: Mongo.Action IO a -> DBAction a 274 | execMongoActionTCB act = do 275 | s <- getActionStateTCB 276 | let pipe = dbActionPipe s 277 | mode = dbActionMode s 278 | db = databaseName . dbActionDB $ s 279 | liftLIO $ ioTCB $ Mongo.access pipe mode db act 280 | 281 | 282 | -- 283 | -- DB failures 284 | -- 285 | 286 | 287 | -- | Exceptions thrown by invalid database queries. 288 | data DBError = UnknownCollection -- ^ Collection does not exist 289 | | UnknownPolicyModule -- ^ Policy module not found 290 | | ExecFailure Failure -- ^ Execution of action failed 291 | deriving (Show, Typeable) 292 | 293 | instance Exception DBError 294 | -------------------------------------------------------------------------------- /Hails/HttpClient.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE FlexibleInstances, 3 | MultiParamTypeClasses, 4 | FlexibleContexts #-} 5 | {- | 6 | 7 | Exports basic HTTP client functions inside the 'DC' Monad. 8 | Computations are allowed to communicate over HTTP as long as they can 9 | read and write to a labeled origin. An origin is associated with two 10 | labels. When writing, the origin has a label of the form 11 | @\< \"scheme:\/\/authority\", |True \>@, where @scheme@ is 12 | either \'http\' or \'https\', and @authority@ is the domain name or IP 13 | address used in the request and port number of the connection. In 14 | other words, the secrecy component contains the origin information, 15 | while the integrity component is the same as that of public data. 16 | When reading, the origin has a label of the form 17 | @\< |True, \"scheme:\/\/authority\" \>@. 18 | 19 | This means that 'DC' computations can export data if the current label 20 | is not higher than that of the labeled origin, and read data that is 21 | no more trustworthy than that of the origin. Practically, this means 22 | that untrusted computation can export data so long as the they have 23 | not observed any data more sensitive than the label of the target 24 | domain. Reading (which also occurs on every request/write) further 25 | raises the current label to the join of the current label and origin. 26 | 27 | For example, suppose some piece of data, @myLoc@, has the label: 28 | 29 | > aliceLocL = dcLabel ("alice" /\ "http://maps.googleapis.com:80") dcTrue 30 | 31 | created as: 32 | 33 | > myLoc <- labelP alicePriv aliceLocL "3101 24th Street, San Francisco, CA" 34 | 35 | 36 | Then, untrusted code (with initial label set to public) running on 37 | behalf of \"alice\" , may perform the following operation: 38 | 39 | > let mapBase = "http://maps.googleapis.com/maps/api/geocode/json?sensor=false" 40 | > aliceLoc <- unlabelP alicePriv myLoc 41 | > resp <- simpleGetHttp $ mapBase ++ "&address=" ++ aliceLoc 42 | 43 | In this case the 'unlabelP' will raise the current label to the label: 44 | 45 | > < "http://maps.googleapis.com:80", |True > 46 | 47 | by exercising \"alice\"s privilges. Directly, the 'simpleHttp' 48 | will be permitted. However, if 49 | 50 | > let mapBase = "http://maps.evilalternatives.org/geocode/json?sensor=false" 51 | 52 | an exception will be thrown since the current label does not flow to 53 | the label of @mapBase@. 54 | 55 | 56 | 57 | This module uses 'http-conduit' as the underlying client, we recommend 58 | looking at the "Network.HTTP.Conduit" documentation on how to 59 | construct 'C.Request's. Here, we highlight some important details: 60 | 61 | * The headers @Content-Length@ and @Host@ are automatically set, and 62 | should not be added to 'requestHeaders'. 63 | 64 | * By default, the functions in this package will /not/ throw 65 | exceptions for non-2xx status codes. If you would like to use the 66 | default http-conduit behavior, you should use 'checkStatus', e.g.: 67 | 68 | > req <- parseUrl mapBase 69 | > resp <- simpleGetHttp $ req { checkStatus = \s@(Status sci _) hs -> 70 | > if 200 <= sci && sci < 300 71 | > then Nothing 72 | > else Just $ toException $ StatusCodeException s hs } 73 | 74 | -} 75 | 76 | module Hails.HttpClient ( 77 | -- * Request type 78 | Request 79 | , method, secure, host, port, path, queryString 80 | , requestHeaders 81 | , requestBody, rawBody 82 | , redirectCount 83 | , checkStatus, decompress 84 | , module Network.HTTP.Types 85 | -- * Response type 86 | , Response(..) 87 | -- * Simple HTTP interface 88 | , parseUrl 89 | , applyBasicAuth 90 | , simpleHttp, simpleHttpP 91 | , simpleGetHttp, simpleGetHttpP 92 | , simpleHeadHttp, simpleHeadHttpP 93 | -- * Exceptions 94 | , HttpException(..) 95 | ) where 96 | 97 | import qualified Data.ByteString.Char8 as S8 98 | import Data.Monoid 99 | 100 | import Control.Monad.Catch 101 | 102 | import qualified Network.HTTP.Conduit as C 103 | import Network.HTTP.Conduit ( 104 | method, secure, host, port, path, queryString 105 | , requestHeaders 106 | , requestBody, rawBody 107 | , redirectCount 108 | , checkStatus, decompress 109 | , proxy 110 | , applyBasicAuth 111 | , HttpException(..) 112 | ) 113 | import Hails.HttpServer (Response(..)) 114 | import Network.HTTP.Types 115 | 116 | import LIO 117 | import LIO.TCB 118 | import LIO.DCLabel 119 | 120 | 121 | -- | Reques type, wrapper for the conduit 'C.Request'. 122 | type Request = C.Request 123 | 124 | -- 125 | -- Basic functions 126 | -- 127 | 128 | -- | Perform a simple HTTP(S) request. 129 | simpleHttp :: Request -- ^ Request 130 | -> DC Response 131 | simpleHttp = simpleHttpP noPrivs 132 | 133 | -- | Same as 'simpleHttp', but uses privileges. 134 | simpleHttpP :: PrivDesc DCLabel p 135 | => Priv p -- ^ Privilege 136 | -> Request -- ^ Request 137 | -> DC Response 138 | simpleHttpP p req' = do 139 | let req = req' { proxy = Nothing } 140 | guardWriteURLP p req 141 | resp <- ioTCB $ C.withManager $ C.httpLbs req 142 | return $ Response { respStatus = C.responseStatus resp 143 | , respHeaders = C.responseHeaders resp 144 | , respBody = C.responseBody resp 145 | } 146 | 147 | -- 148 | -- Simple HEAD/GET Wrappers 149 | -- 150 | 151 | -- | Simple HTTP GET request. 152 | simpleGetHttpP :: DCPriv -- ^ Privilege 153 | -> String -- ^ URL 154 | -> DC Response 155 | simpleGetHttpP p url = do 156 | req <- parseUrl url 157 | simpleHttpP p req 158 | 159 | -- | Simple HTTP GET request. 160 | simpleGetHttp :: String -> DC Response 161 | simpleGetHttp = simpleGetHttpP mempty 162 | 163 | -- | Simple HTTP HEAD request. 164 | simpleHeadHttpP :: DCPriv -- ^ Privilege 165 | -> String -- ^ URL 166 | -> DC Response 167 | simpleHeadHttpP p url = do 168 | req <- parseUrl url 169 | simpleHttpP p $ req { method = methodHead } 170 | 171 | -- | Simple HTTP HEAD request. 172 | simpleHeadHttp :: String -> DC Response 173 | simpleHeadHttp = simpleHeadHttpP mempty 174 | 175 | 176 | -- 177 | -- Misc 178 | -- 179 | 180 | -- | Check that current label can flow to label of request. 181 | guardWriteURLP :: PrivDesc DCLabel p => Priv p -> Request -> DC () 182 | guardWriteURLP p req = do 183 | let (lr, lw) = labelOfReq req 184 | guardAllocP p lr 185 | taintP p lw 186 | 187 | -- | Return the labels corresponding to the absolute URI of a request header. 188 | -- The created labels will have the scheme and authority (including port) in the 189 | -- secrecy componenet, and @|True@ in the integrity component for the 190 | -- read label (and the dual for write label). Specifically, the 191 | -- labels will have the form: 192 | -- 193 | -- > (< scheme://authority, |True >,< |True, scheme://authority >) 194 | -- 195 | -- For example, the read label of a request to \"http:\/\/gitstar.com/\" is: 196 | -- 197 | -- > < "http://gitstar.com:80" , |True> 198 | -- 199 | -- while the read label of \"https:\/\/gitstar.com:444/\" 200 | -- 201 | -- > < "https://gitstar.com:444" , |True> 202 | -- 203 | -- This should be used for only for single-connection requests, where the 204 | -- absolute URL makes senes. 205 | labelOfReq :: Request -> (DCLabel, DCLabel) 206 | labelOfReq req = 207 | let scheme = if secure req then (S8.pack "https://") else (S8.pack "http://") 208 | prin = principalBS $ S8.concat [scheme, host req, S8.pack ":", S8.pack $ show (port req)] 209 | in (prin %% True, True %% prin) 210 | 211 | -- | Convert a URL into a 'Request'. 212 | -- 213 | -- This defaults some of the values in 'Request', such as setting 214 | -- method to GET and 'requestHeaders' to []. 215 | -- 216 | parseUrl :: String -> DC Request 217 | parseUrl = C.parseUrl 218 | 219 | instance MonadThrow (LIO DCLabel) where 220 | throwM = throwLIO 221 | -------------------------------------------------------------------------------- /Hails/HttpServer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {- | 4 | 5 | This module exports the core of the Hails HTTP server. Specifically it 6 | defines basic types, such as HTTP 'Request' and 'Response', used by 7 | the Hails web server and untrusted Hails 'Application's. 8 | 9 | At a high level, a Hails 'Application', is a function from 'Request' 10 | to 'Response' in the 'DC' monad. Every application response is 11 | sanitized and sanity checked with the 'secureApplication' 12 | 'Middleware'. Moreover, every 'Request' is sanitized with 'sanitizeReq' 13 | before handed over to authenticators. 14 | 15 | Hails uses Wai, and as such we provide a function for converting 16 | Hails 'Application's to Wai 'W.Applicatoin's: 'execHailsApplication'. 17 | 18 | -} 19 | module Hails.HttpServer ( 20 | module Hails.HttpServer.Types 21 | -- ** Execute Hails application 22 | , execHailsApplication 23 | -- ** Middleware used by Hails 24 | , sanitizeReqMiddleware 25 | , browserLabelGuard 26 | , guardSensitiveResp 27 | , sanitizeResp 28 | , catchAllExceptions 29 | -- * Network types 30 | , module Network.HTTP.Types 31 | ) where 32 | 33 | import qualified Data.List as List 34 | import qualified Data.Set as Set 35 | import qualified Data.ByteString.Char8 as S8 36 | import qualified Data.ByteString.Lazy as L 37 | import Data.Conduit 38 | import Data.Conduit.List hiding (head) 39 | import Data.Monoid 40 | 41 | import Control.Monad (liftM) 42 | import Control.Monad.IO.Class (liftIO) 43 | import Control.Monad.Error.Class 44 | 45 | 46 | import Network.HTTP.Types 47 | import Network.URI (isURI) 48 | import qualified Network.Wai as W 49 | import qualified Network.Wai.Application.Static as W 50 | import Network.Wai.Middleware.MethodOverridePost 51 | 52 | import LIO 53 | import LIO.TCB 54 | import LIO.DCLabel 55 | 56 | import Hails.HttpServer.Types 57 | 58 | import System.IO 59 | import Data.Time (getCurrentTime) 60 | 61 | -- | Convert a WAI 'W.Request' to a Hails 'Request' by consuming the 62 | -- body into a 'L.ByteString'. The 'requestTime' is set to the 63 | -- current time at the time this action is executed (which is when 64 | -- the app is invoked). 65 | waiToHailsReq :: W.Request -> IO Request 66 | waiToHailsReq req = do 67 | curTime <- liftIO getCurrentTime 68 | body <- fmap L.fromChunks $ W.requestBody req $$ consume 69 | return $ Request { requestMethod = W.requestMethod req 70 | , httpVersion = W.httpVersion req 71 | , rawPathInfo = W.rawPathInfo req 72 | , rawQueryString = W.rawQueryString req 73 | , requestHeaders = W.requestHeaders req 74 | , isSecure = W.isSecure req 75 | , remoteHost = W.remoteHost req 76 | , serverName = sN 77 | , pathInfo = W.pathInfo req 78 | , queryString = W.queryString req 79 | , requestBody = body 80 | , requestTime = curTime } 81 | where sN = case lookup "Host" $ W.requestHeaders req of 82 | Just h -> h 83 | _ -> error "requestToUri: missing Host header" 84 | 85 | -- | Remove any unsafe headers, in this case only @X-Hails-User@. 86 | sanitizeReqMiddleware :: W.Middleware 87 | sanitizeReqMiddleware app req = app $ req { W.requestHeaders = headers } 88 | where headers = List.filter ((/= "X-Hails-User") . fst) $ W.requestHeaders req 89 | 90 | -- | Convert a Hails 'Response' to a WAI 'W.Response' 91 | hailsToWaiResponse :: Response -> W.Response 92 | hailsToWaiResponse (Response stat rhd body) = W.responseLBS stat rhd body 93 | 94 | -- | Hails 'Middleware' that ensures the 'Response' from the 95 | -- application is readable by the client's browser (as determined by the 96 | -- result label of the app computation and the label of the browser). If 97 | -- the response is not readable by the browser, the middleware sends a 98 | -- 403 (unauthorized) response instead. 99 | browserLabelGuard :: Middleware 100 | browserLabelGuard hailsApp conf req = do 101 | response <- hailsApp conf req 102 | resultLabel <- getLabel 103 | return $ if resultLabel `canFlowTo` (browserLabel conf) 104 | then response 105 | else Response status403 [] "" 106 | 107 | -- | Adds the header @Content-Security-Policy@ to the response, if the 108 | -- label of the computation does not flow to the public label, 109 | -- 'dcPublic'. The @default-src@ directive is set to the secrecy 110 | -- component of the response label (if it is a disjunction 111 | -- of principals). Currently, @'self'@ is always added to the 112 | -- whitelist. An example may be: 113 | -- 114 | -- > Content-Security-Policy: default-src 'self' http://google.com:80 https://a.lvh.me:3000; 115 | -- 116 | guardSensitiveResp :: Middleware 117 | guardSensitiveResp app config req = do 118 | response <- (flip removeResponseHeader) csp `liftM` app config req 119 | resultLabel <- getLabel 120 | return $ if resultLabel `canFlowTo` dcPublic 121 | then response 122 | else addResponseHeader response $ 123 | ( csp 124 | , "default-src " <> headerVal resultLabel <> ";") 125 | where csp = "Content-Security-Policy" 126 | headerVal l = 127 | let secrecy = dcSecrecy l 128 | secrecySet = cToSet secrecy 129 | uriList = Set.filter (isURI . S8.unpack) $ 130 | Set.map principalName $ 131 | dToSet $ head $ Set.elems secrecySet 132 | in if secrecy == cFalse || Set.size secrecySet > 1 133 | then "'self','unsafe-inline'" -- Be more flexible than 'none' 134 | else S8.unwords $ 135 | "'self'":"'unsafe-inline'":(Set.toList uriList) 136 | 137 | -- | Remove anything from the response that could cause inadvertant 138 | -- declasification. Currently this only removes the @Set-Cookie@ 139 | -- header. 140 | sanitizeResp :: Middleware 141 | sanitizeResp hailsApp conf req = do 142 | response <- hailsApp conf req 143 | return $ foldr (\h r -> removeResponseHeader r h) response unsafeHeaders 144 | where unsafeHeaders = ["Set-Cookie"] 145 | 146 | 147 | 148 | -- | Returns a secure Hails app such that the result 'Response' is guaranteed 149 | -- to be safe to transmit to the client's browser. The definition is 150 | -- straight forward from other middleware: 151 | -- 152 | -- > secureApplication = 'browserLabelGuard' -- Return 403, if user should not read 153 | -- > . 'sanitizeResp' -- Remove Cookies/CSP 154 | -- > . 'guardSensitiveResp' -- Add CSP if not public 155 | secureApplication :: Middleware 156 | secureApplication = browserLabelGuard -- Return 403, if user should not read 157 | . sanitizeResp -- Remove Cookies and X-Hails-Sensitive 158 | . guardSensitiveResp -- Add CSP if not public 159 | 160 | -- | Catch all exceptions thrown by middleware and return 500. 161 | catchAllExceptions :: W.Middleware 162 | catchAllExceptions app req = app req `catchError` (const $ return resp500) 163 | where resp500 = W.responseLBS status500 [] "App threw an exception" 164 | 165 | -- 166 | -- Executing Hails applications 167 | -- 168 | 169 | -- | Execute an application, safely filtering unsafe request headers, 170 | -- overriding method posts, catching all exceptions, and sanitizing 171 | -- responses. 172 | execHailsApplication :: W.Middleware -> Application -> W.Application 173 | execHailsApplication authMiddleware app = 174 | catchAllExceptions 175 | . sanitizeReqMiddleware 176 | . methodOverridePost 177 | . authMiddleware 178 | $ \req -> hailsApplicationToWai app req 179 | 180 | -- | Safely wraps a Hails 'Application' in a Wai 'W.Application' that can 181 | -- be run by an application server. The application is executed with the 182 | -- 'secureApplication' 'Middleware'. The function returns status 500 if 183 | -- the Hails application throws an exception and the label of the 184 | -- exception flows to the browser label (see 'browserLabelGuard'); if the 185 | -- label does not flow, it responds with a 403. 186 | -- 187 | -- All applications serve static content from a @\"static\"@ directory. 188 | -- 189 | -- Note: this function assumes that the request has already been sanitized. 190 | -- In most cases, you want to use 'execHailsApplication'. 191 | hailsApplicationToWai :: Application -> W.Application 192 | hailsApplicationToWai app0 req0 | isStatic req0 = 193 | -- Is static request, serve files: 194 | W.staticApp (W.defaultWebAppSettings "./") req0 195 | | otherwise = do 196 | -- Not static request, serve dynamic content: 197 | -- Convert request to Hails request 198 | hailsRequest <- waiToHailsReq req0 199 | -- Extract browser/request configuration 200 | let conf = getRequestConf hailsRequest 201 | (result, dcState) <- liftIO $ tryDCDef conf $ do 202 | let lreq = LabeledTCB (requestLabel conf) hailsRequest 203 | app conf lreq 204 | case result of 205 | Right response -> return $ hailsToWaiResponse response 206 | Left err -> do 207 | liftIO $ hPutStrLn stderr $ "App threw exception: " ++ show err 208 | return $ 209 | if lioLabel dcState `canFlowTo` (browserLabel conf) then 210 | resp500 211 | else resp403 212 | where app = secureApplication app0 213 | isStatic req = case W.pathInfo req of 214 | ("static":_) -> True 215 | _ -> False 216 | resp403 = W.responseLBS status403 [] "" 217 | resp500 = W.responseLBS status500 [] "" 218 | tryDCDef conf act = tryDC $ do 219 | putLIOStateTCB $ LIOState { lioLabel = dcPublic 220 | , lioClearance = browserLabel conf} 221 | act 222 | 223 | 224 | -- 225 | -- Helper 226 | -- 227 | 228 | -- | Get the browser label (secrecy of the user), request label (integrity of 229 | -- the user), and application privilege (minted with the app's cannonical name) 230 | getRequestConf :: Request -> RequestConfig 231 | getRequestConf req = 232 | let headers = requestHeaders req 233 | muserName = principalBS `fmap` lookup "x-hails-user" headers 234 | appName = "@" `S8.append` (S8.takeWhile (/= '.') $ serverName req) 235 | appPriv = PrivTCB $ toCNF $ principalBS appName 236 | in RequestConfig 237 | { browserLabel = maybe dcPublic (\userName -> userName %% True) muserName 238 | , requestLabel = maybe dcPublic (\userName -> True %% userName) muserName 239 | , appPrivilege = appPriv } 240 | 241 | 242 | -------------------------------------------------------------------------------- /Hails/HttpServer/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {- | 4 | 5 | This module exports generic definitions for Wai-authentication pipelines 6 | in Hails. 'requireLoginMiddleware' looks for the @X-Hails-Login@ 7 | header from an 'Application' \'s 'Response' and, if present, responds to 8 | the user with an authentication request instead of the 'Application' 9 | response (e.g., a redirect to a login page or an HTTP response with 10 | status 401). 11 | 12 | Additionally, this module exports authentication 'Middleware's for basic HTTP 13 | authentication, 'devBasicAuth', (useful in development environments) 14 | and federated (OpenID) authentication, 'openIdAuth'. In general, 15 | authentication 'Middleware's are expected to set the @X-Hails-User@ 16 | header on the request if it is from an authenticated user. 17 | 18 | -} 19 | module Hails.HttpServer.Auth 20 | ( requireLoginMiddleware 21 | -- * Production 22 | -- ** Persona (BrowserID) 23 | , personaAuth 24 | -- ** OpenID 25 | , openIdAuth 26 | -- ** Authenticate with external app 27 | , externalAuth 28 | -- * Development: basic authentication 29 | , devBasicAuth 30 | ) where 31 | 32 | import Control.Monad.IO.Class (liftIO) 33 | import Blaze.ByteString.Builder (toByteString) 34 | import Control.Monad 35 | import Data.Time.Clock 36 | import Data.ByteString.Base64 37 | import Data.Text (Text) 38 | import qualified Data.Text as T 39 | import qualified Data.Text.Encoding as T 40 | import Data.Maybe (fromMaybe, isJust, fromJust) 41 | import qualified Data.ByteString.Char8 as S8 42 | import qualified Data.ByteString.Lazy.Char8 as L8 43 | import qualified Data.Conduit as C 44 | import qualified Data.Conduit.List as C 45 | import Data.Digest.Pure.SHA 46 | import Network.HTTP.Conduit (withManager) 47 | import Network.HTTP.Types 48 | import Network.Wai 49 | import Network.Socket 50 | import Web.Authenticate.BrowserId 51 | import Web.Authenticate.OpenId 52 | import Web.Cookie 53 | 54 | 55 | -- | Basic HTTP authentication middleware for development. Accepts any username 56 | -- and password. 57 | devBasicAuth :: Middleware 58 | devBasicAuth app0 req0 = do 59 | let resp = responseLBS status401 60 | [( "WWW-Authenticate", "Basic realm=\"Hails development.\"")] "" 61 | let req = case getBasicAuthUser req0 of 62 | Nothing -> req0 63 | Just user -> req0 { requestHeaders = ("X-Hails-User", user) 64 | : requestHeaders req0 } 65 | requireLoginMiddleware (return resp) app0 req 66 | 67 | -- | Authentica user with Mozilla's persona. 68 | -- If the @X-Hails-Persona-Login@ header is set, this intercepts the 69 | -- request and verifies the supplied identity assertion, supplied in the 70 | -- request body. 71 | -- 72 | -- If the authentication is successful, set the @_hails_user@ and 73 | -- @_hails_user_hmac@ cookies to identify the user. The former 74 | -- contains the user email address, the latter contains the MAC that is 75 | -- used for verifications in later requests. 76 | -- 77 | -- If the @X-Hails-Persona-Logout@ header is set, this intercepts the 78 | -- request and deletes the aforementioned cookies. 79 | -- 80 | -- If the app wishes the user to authenticate (by setting @X-Hails-Login@) 81 | -- this redirects to @audience/login@ -- where the app can call 82 | -- @navigator.request()@. 83 | -- 84 | personaAuth :: L8.ByteString -> Text -> Middleware 85 | personaAuth key audience app0 req0 = do 86 | case () of 87 | _ | doLogin -> do 88 | assertion <- S8.concat `liftM` (requestBody req0 C.$$ C.consume) 89 | muser <- withManager $ checkAssertion audience (T.decodeUtf8 $ assertion) 90 | case muser of 91 | Nothing -> return $ responseLBS status401 [] "" 92 | Just usr -> let hmac = T.pack $ showDigest $ hmacSha1 key 93 | (L8.fromStrict . T.encodeUtf8 $ usr) 94 | in return $ responseLBS status200 95 | [ ("Set-Cookie", setCookie "_hails_user" usr) 96 | , ("Set-Cookie", setCookie "_hails_user_hmac" hmac)] 97 | "" 98 | _ | doLogout -> return $ responseLBS status200 99 | [ ("Set-Cookie", delCookie "_hails_user") 100 | , ("Set-Cookie", delCookie "_hails_user_hmac")] 101 | "" 102 | _ -> 103 | let mauth = do cookies <- parseCookies `liftM` 104 | (lookup "Cookie" $ requestHeaders req0) 105 | usr <- lookup "_hails_user" cookies 106 | hmac0 <- lookup "_hails_user_hmac" cookies 107 | let hmac1 = showDigest $ hmacSha1 key $ L8.fromStrict usr 108 | return (usr, hmac0 == S8.pack hmac1) 109 | req = case mauth of 110 | Just (usr, True) -> req0 { requestHeaders = 111 | ("X-Hails-User", usr) 112 | :(requestHeaders req0) } 113 | _ -> req0 114 | in requireLoginMiddleware (return $ respRedir req) app0 req 115 | where doLogin = isJust $ lookup "X-Hails-Persona-Login" $ requestHeaders req0 116 | doLogout = isJust $ lookup "X-Hails-Persona-Logout" $ requestHeaders req0 117 | setCookie n v = toByteString . renderSetCookie $ def { 118 | setCookieName = n 119 | , setCookiePath = Just "/" 120 | , setCookieValue = T.encodeUtf8 v } 121 | delCookie n = toByteString . renderSetCookie $ def { 122 | setCookieName = n 123 | , setCookiePath = Just "/" 124 | , setCookieValue = "deleted" 125 | , setCookieExpires = Just $ UTCTime (toEnum 0) 0 } 126 | respRedir req = 127 | let cookie = toByteString . renderSetCookie $ def 128 | { setCookieName = "redirect_to" 129 | , setCookiePath = Just "/" 130 | , setCookieValue = rawPathInfo req } 131 | in responseLBS status302 132 | [ ("Set-Cookie", cookie) 133 | , ("Location", (T.encodeUtf8 audience) `S8.append` "/login") ] "" 134 | 135 | -- | Perform OpenID authentication. 136 | openIdAuth :: T.Text -- ^ OpenID Provider 137 | -> Middleware 138 | openIdAuth openIdUrl app0 req0 = do 139 | case pathInfo req0 of 140 | "_hails":"logout":_ -> do 141 | let cookie = toByteString . renderSetCookie $ def 142 | { setCookieName = "hails_session" 143 | , setCookiePath = Just "/" 144 | , setCookieValue = "deleted" 145 | , setCookieExpires = Just $ UTCTime (toEnum 0) 0} 146 | let redirectTo = fromMaybe "/" $ lookup "Referer" $ requestHeaders req0 147 | return $ responseLBS status302 [ ("Set-Cookie", cookie) 148 | , ("Location", redirectTo)] "" 149 | "_hails":"login":_ -> do 150 | let qry = map (\(n,v) -> (n, fromJust v)) $ filter (isJust . snd) $ 151 | parseQueryText $ rawQueryString req0 152 | oidResp <- withManager $ authenticateClaimed qry 153 | liftIO $ print $ oirParams oidResp 154 | let cookie = toByteString . renderSetCookie $ def 155 | { setCookieName = "hails_session" 156 | , setCookiePath = Just "/" 157 | , setCookieValue = S8.pack . T.unpack . identifier . oirOpLocal $ oidResp } 158 | let redirectTo = fromMaybe "/" $ do 159 | rawCookies <- lookup "Cookie" $ requestHeaders req0 160 | lookup "redirect_to" $ parseCookies rawCookies 161 | return $ responseLBS status200 ([ ("Set-Cookie", cookie) 162 | , ("Location", redirectTo)]) 163 | (L8.pack $ show qry) 164 | _ -> do 165 | let req = fromMaybe req0 $ do 166 | rawCookies <- lookup "Cookie" $ requestHeaders req0 167 | user <- lookup "hails_session" $ parseCookies rawCookies 168 | return $ req0 { requestHeaders = 169 | ("X-Hails-User", user):(requestHeaders req0) 170 | } 171 | let redirectResp = do 172 | let returnUrl = T.pack . S8.unpack $ requestToUri req "/_hails/login" 173 | url <- withManager $ getForwardUrl openIdUrl returnUrl Nothing 174 | [ ("openid.ns.ax", "http://openid.net/srv/ax/1.0") 175 | , ("openid.ax.mode", "fetch_request") 176 | , ("openid.ax.type.email", "http://schema.openid.net/contact/email") 177 | , ("openid.ax.required", "email")] 178 | let cookie = toByteString . renderSetCookie $ def 179 | { setCookieName = "redirect_to" 180 | , setCookiePath = Just "/_hails/" 181 | , setCookieValue = rawPathInfo req } 182 | return $ responseLBS status302 [ ("Location", (S8.pack . T.unpack $ url)) 183 | , ("Set-Cookie", cookie)] "" 184 | requireLoginMiddleware redirectResp app0 req 185 | 186 | -- | Executes the app and if the app 'Response' has header 187 | -- @X-Hails-Login@ and the user is not logged in, respond with an 188 | -- authentication response (Basic Auth, redirect, etc.) 189 | requireLoginMiddleware :: IO Response -> Middleware 190 | requireLoginMiddleware loginResp app0 req = do 191 | appResp <- app0 req 192 | if hasLogin appResp && notLoggedIn 193 | then loginResp 194 | else return appResp 195 | where hasLogin r = "X-Hails-Login" `isIn` responseHeaders r 196 | notLoggedIn = not $ "X-Hails-User" `isIn` requestHeaders req 197 | isIn n xs = isJust $ lookup n xs 198 | 199 | -- 200 | -- Helpers 201 | -- 202 | 203 | -- | Helper method for implementing basic authentication. Given a 204 | -- 'Request' returns the usernamepair from the basic authentication 205 | -- header if present. 206 | getBasicAuthUser :: Request -> Maybe S8.ByteString 207 | getBasicAuthUser req = do 208 | authStr <- lookup hAuthorization $ requestHeaders req 209 | unless ("Basic" `S8.isPrefixOf` authStr) $ fail "Not basic auth." 210 | let up = fmap (S8.split ':') $ decode $ S8.drop 6 authStr 211 | case up of 212 | Right (user:_:[]) -> return user 213 | _ -> fail "Malformed basic auth header." 214 | 215 | -- | Given a request and path, extract the scheme, 216 | -- hostname and port from the request and createand a URI 217 | -- @scheme://hostname[:port]/path@. 218 | requestToUri :: Request -> S8.ByteString -> S8.ByteString 219 | requestToUri req path = S8.concat $ 220 | [ "http" 221 | , if isSecure req then "s://" else "://" 222 | , serverName 223 | , if serverPort `notElem` [80, 443] then portBS else "" 224 | , path ] 225 | where portBS = S8.pack $ ":" ++ show serverPort 226 | serverName = case lookup "Host" $ requestHeaders req of 227 | Just h -> h 228 | _ -> error "requestToUri: missing Host header" 229 | serverPort = case remoteHost req of 230 | SockAddrInet no _ -> no 231 | SockAddrInet6 no _ _ _ -> no 232 | _ -> error "requestToUri: invalid socket type" 233 | 234 | 235 | -- Cookie authentication 236 | -- 237 | 238 | -- | Use an external authentication service that sets cookies. 239 | -- The cookie names are @_hails_user@, whose contents contains the 240 | -- @user-name@, and @_hails_user_hmac@, whose contents contains 241 | -- @HMAC-SHA1(user-name)@. This function simply checks that the cookie 242 | -- exists and the MAC'd user name is correct. If this is the case, it 243 | -- returns a request with the cookie removed and @x-hails-user@ header 244 | -- set. Otherwies the original request is returned. 245 | -- The login service retuns a redirect (to the provided url). 246 | -- Additionally, cookie @_hails_refer$ is set to the current 247 | -- URL (@scheme://domain:port/path@). 248 | externalAuth :: L8.ByteString -> String -> Middleware 249 | externalAuth key url app req = do 250 | let mreqAuth = do 251 | cookieHeaders <- lookup hCookie $ requestHeaders req 252 | let cookies = parseCookies cookieHeaders 253 | mac0 <- fmap (S8.takeWhile (/= '"') . S8.dropWhile (== '"')) $ lookup "_hails_user_hmac" cookies 254 | user <- fmap (S8.takeWhile (/= '"') . S8.dropWhile (== '"')) $ lookup "_hails_user" cookies 255 | let mac1 = showDigest $ hmacSha1 key (lazyfy user) 256 | if S8.unpack mac0 == mac1 257 | then Just $ req { requestHeaders = ("X-Hails-User", user) 258 | : requestHeaders req } 259 | else Nothing 260 | req0 = maybe req id mreqAuth 261 | requireLoginMiddleware redirectResp app req0 262 | where redirectResp = return $ responseLBS status302 263 | [(hLocation, S8.pack url)] "" 264 | -- 265 | lazyfy = L8.fromChunks . (:[]) 266 | 267 | -------------------------------------------------------------------------------- /Hails/HttpServer/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-} 3 | module Hails.HttpServer.Types ( 4 | -- * Requests 5 | Request(..) 6 | , getRequestBodyType, RequestBodyType(..) 7 | , addRequestHeader, removeRequestHeader 8 | -- * Responses 9 | , Response(..) 10 | , module Network.HTTP.Types 11 | , addResponseHeader, removeResponseHeader 12 | -- * Applications and middleware 13 | , Application, RequestConfig(..) 14 | , Middleware 15 | ) where 16 | 17 | import qualified Data.List as List 18 | import Data.Text (Text) 19 | import Data.Typeable 20 | import qualified Data.ByteString as S 21 | import qualified Data.ByteString.Char8 as S8 22 | import qualified Data.ByteString.Lazy as L 23 | 24 | import Network.Socket (SockAddr) 25 | import Network.HTTP.Types 26 | import Network.Wai.Parse (RequestBodyType(..)) 27 | 28 | import Data.Time (UTCTime) 29 | 30 | import LIO.DCLabel 31 | 32 | -- 33 | -- Request 34 | -- 35 | 36 | -- | A request sent by the end-user. 37 | data Request = Request { 38 | -- | HTTP Request (e.g., @GET@, @POST@, etc.). 39 | requestMethod :: Method 40 | -- | HTTP version (e.g., 1.1 or 1.0). 41 | , httpVersion :: HttpVersion 42 | -- | Extra path information sent by the client. 43 | , rawPathInfo :: S.ByteString 44 | -- | If no query string was specified, this should be empty. This value 45 | -- /will/ include the leading question mark. 46 | -- Do not modify this raw value- modify queryString instead. 47 | , rawQueryString :: S.ByteString 48 | -- | Generally the host requested by the user via the Host request header. 49 | -- Backends are free to provide alternative values as necessary. This value 50 | -- should not be used to construct URLs. 51 | , serverName :: S.ByteString 52 | -- | The request headers. 53 | , requestHeaders :: RequestHeaders 54 | -- | Was this request made over an SSL connection? 55 | , isSecure :: Bool 56 | -- | The client\'s host information. 57 | , remoteHost :: SockAddr 58 | -- | Path info in individual pieces- the url without a hostname/port 59 | -- and without a query string, split on forward slashes, 60 | , pathInfo :: [Text] 61 | -- | Parsed query string information 62 | , queryString :: Query 63 | -- | Lazy ByteString containing the request body. 64 | , requestBody :: L.ByteString 65 | -- | Time request was received. 66 | , requestTime :: UTCTime 67 | } deriving (Show, Typeable) 68 | 69 | -- | Get the request body type (copied from @wai-extra@). 70 | getRequestBodyType :: Request -> Maybe RequestBodyType 71 | getRequestBodyType req = do 72 | ctype <- lookup "Content-Type" $ requestHeaders req 73 | if urlenc `S.isPrefixOf` ctype 74 | then Just UrlEncoded 75 | else case boundary ctype of 76 | Just x -> Just $ Multipart x 77 | Nothing -> Nothing 78 | where 79 | urlenc = S8.pack "application/x-www-form-urlencoded" 80 | formBound = S8.pack "multipart/form-data;" 81 | bound' = "boundary=" 82 | boundary s = 83 | if "multipart/form-data;" `S.isPrefixOf` s 84 | then 85 | let s' = S.dropWhile (== 32) $ S.drop (S.length formBound) s 86 | in if bound' `S.isPrefixOf` s' 87 | then Just $ S.drop (S.length bound') s' 88 | else Nothing 89 | else Nothing 90 | 91 | -- | Add/replace a 'Header' to the 'Request' 92 | addRequestHeader :: Request -> Header -> Request 93 | addRequestHeader req hdr@(hname, _) = req { requestHeaders = hdr:headers } 94 | 95 | where headers = List.filter ((/= hname) . fst) $ requestHeaders req 96 | -- | Remove a header (if it exists) from the 'Request' 97 | removeRequestHeader :: Request -> HeaderName -> Request 98 | removeRequestHeader req hname = req { requestHeaders = headers } 99 | where headers = List.filter ((/= hname) . fst) $ requestHeaders req 100 | 101 | 102 | -- 103 | -- Response 104 | -- 105 | 106 | -- | A response sent by the app. 107 | data Response = Response { 108 | -- | Response status 109 | respStatus :: Status 110 | -- | Response headers 111 | , respHeaders :: ResponseHeaders 112 | -- | Response body 113 | , respBody :: L.ByteString 114 | } deriving (Show, Typeable) 115 | 116 | -- | Add/replace a 'Header' to the 'Response' 117 | addResponseHeader :: Response -> Header -> Response 118 | addResponseHeader resp hdr@(hname, _) = resp { respHeaders = hdr:headers } 119 | where headers = List.filter ((/= hname) . fst) $ respHeaders resp 120 | 121 | -- | Remove a header (if it exists) from the 'Response' 122 | removeResponseHeader :: Response -> HeaderName -> Response 123 | removeResponseHeader resp hname = resp { respHeaders = headers } 124 | where headers = List.filter ((/= hname) . fst) $ respHeaders resp 125 | 126 | 127 | -- 128 | -- Application & middleware 129 | -- 130 | 131 | -- | The settings with which the app will run. 132 | data RequestConfig = RequestConfig { 133 | -- | The label of the browser the reponse will be sent to. 134 | browserLabel :: DCLabel 135 | -- | The label of the incoming request (with the logged in user's integrity). 136 | , requestLabel :: DCLabel 137 | -- | A privilege minted for the app. 138 | , appPrivilege :: DCPriv 139 | } deriving (Show, Typeable) 140 | 141 | -- | Base Hails type implemented by untrusted applications. 142 | type Application = RequestConfig -> DCLabeled Request -> DC Response 143 | 144 | -- | Convenience type for middleware components. 145 | type Middleware = Application -> Application 146 | -------------------------------------------------------------------------------- /Hails/PolicyModule/Groups.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {- | This module exports a class 'Groups' that policy modules 4 | must define an instance of to define groups, or mappings 5 | between a group 'Principal'and the principals in the group. 6 | 7 | An app may then relabel a labeled value by using 'labelRewrite'. 8 | 9 | 10 | -} 11 | module Hails.PolicyModule.Groups ( Groups(..) 12 | , labelRewrite ) where 13 | 14 | import Data.Monoid 15 | import qualified Data.Set as Set 16 | import qualified Data.Map as Map 17 | 18 | import Control.Monad 19 | 20 | import LIO 21 | import LIO.DCLabel 22 | 23 | import Hails.Database 24 | import Hails.Database.TCB (dbActionPriv, getActionStateTCB) 25 | import Hails.PolicyModule 26 | 27 | 28 | class PolicyModule pm => Groups pm where 29 | -- | Typically, the action should expand a principal such as @#group@ to 30 | -- list of group members @[alice, bob]@. 31 | groups :: pm -- ^ Unused type-enforcing param 32 | -> DCPriv -- ^ Policy module privs 33 | -> Principal -- ^ Group 34 | -> DBAction [Principal] -- ^ (Policy module, group members) 35 | -- | Endorse the implementation of this instance. Note that this is 36 | -- reduced to WHNF to catch invalid instances that use 'undefined'. 37 | -- 38 | -- Example implementation: 39 | -- 40 | -- > groupsInstanceEndorse _ = MyPolicyModuleTCB {- Leave other values undefined -} 41 | groupsInstanceEndorse :: pm 42 | 43 | -- | Given the policy module (which is used to invoke the right 44 | -- 'groups' function) and labeled value, relabel the value according 45 | -- to the 'Groups' of the policy module. Note that the first argument 46 | -- may be bottom since it is solely used for typing purposes. 47 | labelRewrite :: forall unused_pm a. Groups unused_pm 48 | => unused_pm 49 | -- ^ Policy module 50 | -> DCLabeled a 51 | -- ^ Label 52 | -> DBAction (DCLabeled a) 53 | labelRewrite pm lx = withDBContext "labelRewrite" $ do 54 | -- Make sure that 'groupsInstanceEndorse' is not bottom 55 | _ <- liftLIO $ evaluate (groupsInstanceEndorse :: unused_pm) 56 | pmPriv <- getPMPriv 57 | 58 | -- Build map from principals to list of princpals 59 | pMap <- Set.fold (\p act -> act >>= \m -> do 60 | ps <- groups pm pmPriv p 61 | return (Map.insert p ps m)) (return Map.empty) principals 62 | -- Apply map to all principals in the label 63 | let lnew = (expandPrincipals pMap s) %% (expandPrincipals pMap i) 64 | -- Relabel labeled value 65 | liftLIO $ withPMClearanceP pmPriv $ relabelLabeledP pmPriv lnew lx 66 | where getPMPriv = do 67 | pmPriv <- dbActionPriv `liftM` getActionStateTCB 68 | -- Make sure that the underlying policy module 69 | -- and one named in the first parameter are the same 70 | case Map.lookup (policyModuleTypeName pm) availablePolicyModules of 71 | Nothing -> return mempty 72 | Just (p,_,_) -> return $ if toCNF p == privDesc pmPriv 73 | then pmPriv 74 | else mempty 75 | -- Modify label by expanding principals according to the map 76 | expandPrincipals pMap origPrincipals = 77 | -- Function to fold over disjunctions in a CNF, expanding each 78 | -- principal with the groups map 79 | let cFoldF :: Disjunction -> CNF -> CNF 80 | cFoldF disj accm = 81 | (Set.foldr expandOne cFalse $ dToSet disj) /\ accm 82 | -- Inner fold function, expands a single principal and adds 83 | -- to a CNF (that represents a Disjunction 84 | expandOne :: Principal -> CNF -> CNF 85 | expandOne princ accm = 86 | (dFromList $ pMap Map.! princ) \/ accm 87 | in Set.foldr cFoldF cTrue $ cToSet origPrincipals 88 | -- Label components 89 | s = dcSecrecy $ labelOf lx 90 | i = dcIntegrity $ labelOf lx 91 | -- All unique principals in the labe 92 | principals = getPrincipals s <> getPrincipals i 93 | -- Get principals form component 94 | getPrincipals = mconcat . (map dToSet) . Set.elems . cToSet 95 | 96 | -------------------------------------------------------------------------------- /Hails/PolicyModule/TCB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Unsafe #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, 3 | MultiParamTypeClasses #-} 4 | 5 | {- | 6 | 7 | This module exports a newtype wrapper for 'DBAction' that restricts 8 | certain combinators solely to policy modules. Specifically, this 9 | policy module monad ('PMAction') is used when setting labels, 10 | specifing policies, creating collections, etc. The newtype is used to 11 | restrict such functionality to policy modules; apps cannot and should 12 | not be concerned with specifying data models and policies. 13 | 14 | -} 15 | 16 | 17 | module Hails.PolicyModule.TCB ( 18 | PMAction(..) 19 | ) where 20 | 21 | 22 | import Control.Applicative 23 | 24 | import LIO 25 | import LIO.DCLabel 26 | import Hails.Database.Core 27 | 28 | -- | A policy module action (@PMAction@) is simply a wrapper for 29 | -- database action ('DBAction'). The wrapper is used to restrict /app/ 30 | -- code from specifying policies; only policy module may execute 31 | -- @PMAction@s, and thus create collections, set a label on their 32 | -- databases, etc. 33 | newtype PMAction a = PMActionTCB { unPMActionTCB :: DBAction a } 34 | deriving (Monad, Functor, Applicative) 35 | 36 | instance MonadLIO DCLabel PMAction where 37 | liftLIO = liftDB . liftLIO 38 | 39 | instance MonadDB PMAction where 40 | liftDB = PMActionTCB 41 | -------------------------------------------------------------------------------- /Hails/Version.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {- | 3 | 4 | This module solely exports the version of hails. 5 | 6 | -} 7 | 8 | module Hails.Version (version) where 9 | import Paths_hails 10 | -------------------------------------------------------------------------------- /Hails/Web.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {- | 3 | 4 | This module re-exports the routing and controller modules. 5 | See each module for their corresponding documentation. 6 | 7 | Though you can implement a controller using the methods supplied by 8 | this module (actually, "Hails.Web.Router"), we recommend using the 9 | DSLs provided by "Hails.Web.Frank" or "Hails.Web.REST". 10 | 11 | -} 12 | module Hails.Web ( 13 | module Hails.Web.Router 14 | , module Hails.Web.Responses 15 | , module Hails.Web.Controller 16 | , module Hails.Web.User 17 | ) where 18 | 19 | import Hails.Web.Router 20 | import Hails.Web.Responses 21 | import Hails.Web.Controller 22 | import Hails.Web.User 23 | -------------------------------------------------------------------------------- /Hails/Web/Controller.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | {-# LANGUAGE OverloadedStrings 3 | , TypeSynonymInstances 4 | , FlexibleInstances 5 | , FlexibleInstances 6 | , MultiParamTypeClasses #-} 7 | 8 | {- | 9 | This module exports a definition of a 'Controller', which is simply a 10 | 'DC' action with the 'Labeled' HTTP 'Request' in the environment 11 | (i.e., it is a 'Reader' monad). 12 | -} 13 | 14 | module Hails.Web.Controller 15 | ( Controller, ControllerState(..) 16 | , request 17 | , requestConfig 18 | , appPriv 19 | , requestHeader 20 | , body 21 | , queryParam 22 | , respond 23 | , redirectBack 24 | , redirectBackOr 25 | ) where 26 | 27 | import LIO 28 | import LIO.DCLabel 29 | 30 | import Control.Monad.Trans.Class 31 | import Control.Monad.Trans.Reader 32 | 33 | import qualified Data.ByteString.Char8 as S8 34 | import qualified Data.ByteString.Lazy.Char8 as L8 35 | 36 | import Hails.HttpServer 37 | import Hails.Web.Router 38 | import Hails.Web.Responses 39 | 40 | data ControllerState = ControllerState 41 | { csRequest :: DCLabeled Request 42 | , csPathParams :: Query 43 | , csReqConfig :: RequestConfig } 44 | 45 | -- | A controller is simply a reader monad atop 'DC' with the 'Labeled' 46 | -- 'Request' as the environment. 47 | type Controller = ReaderT ControllerState DC 48 | 49 | instance MonadLIO DCLabel Controller where 50 | liftLIO = lift 51 | 52 | instance Routeable (Controller Response) where 53 | runRoute controller _ eq conf req = fmap Just $ 54 | runReaderT controller $ ControllerState req eq conf 55 | 56 | -- | Get the underlying request. 57 | request :: Controller (DCLabeled Request) 58 | request = fmap csRequest ask 59 | 60 | requestConfig :: Controller RequestConfig 61 | requestConfig = fmap csReqConfig ask 62 | 63 | appPriv :: Controller DCPriv 64 | appPriv = fmap appPrivilege requestConfig 65 | 66 | -- | Get the underlying request. 67 | pathParams :: Controller [(S8.ByteString, Maybe S8.ByteString)] 68 | pathParams = fmap csPathParams ask 69 | 70 | -- | Get the query parameter mathing the supplied variable name. 71 | queryParam :: S8.ByteString -> Controller (Maybe S8.ByteString) 72 | queryParam varName = do 73 | req <- request >>= liftLIO . unlabel 74 | params <- pathParams 75 | let qr = queryString req 76 | case lookup varName (params ++ qr) of 77 | Just n -> return n 78 | _ -> return Nothing 79 | 80 | -- | Produce a response. 81 | respond :: Routeable r => r -> Controller r 82 | respond = return 83 | 84 | -- | Extract the body in the request (after unlabeling it). 85 | body :: Controller L8.ByteString 86 | body = request >>= liftLIO . unlabel >>= return . requestBody 87 | 88 | -- | Get a request header 89 | requestHeader :: HeaderName -> Controller (Maybe S8.ByteString) 90 | requestHeader name = do 91 | req <- request >>= liftLIO . unlabel 92 | return $ lookup name $ requestHeaders req 93 | 94 | -- | Redirect back acording to the referer header. If the header is 95 | -- not present redirect to root (i.e., @\/@). 96 | redirectBack :: Controller Response 97 | redirectBack = redirectBackOr (redirectTo "/") 98 | 99 | -- | Redirect back acording to the referer header. If the header is 100 | -- not present return the given response. 101 | redirectBackOr :: Response -> Controller Response 102 | redirectBackOr def = do 103 | mrefr <- requestHeader "referer" 104 | return $ case mrefr of 105 | Just refr -> redirectTo $ S8.unpack refr 106 | Nothing -> def 107 | -------------------------------------------------------------------------------- /Hails/Web/Frank.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {- | 3 | Frank is a Sinatra-inspired DSL (see ) for creating 4 | routes. It is composable with all 'Routeable' types, but is designed to be used 5 | with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a 6 | URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for 7 | details) and a 'Routeable': 8 | 9 | @ 10 | module SimpleFrank (server) where 11 | 12 | import "Data.String" 13 | import "Data.Maybe" 14 | import "Control.Monad" 15 | 16 | import "LIO" 17 | import "Hails.HttpServer.Types" 18 | import "Hails.Web" 19 | import qualified "Hails.Web.Frank" as F 20 | 21 | server :: 'Application' 22 | server = 'mkRouter' $ do 23 | F.'get' \"\/users\" $ do 24 | req \<- 'request' '>>=' unlabel 25 | return $ 'okHtml' $ 'fromString' $ 26 | \"Welcome Home \" ++ (show $ 'serverName' req) 27 | F.'get' \"\/users\/:id\" $ do 28 | userId <- fromMaybe \"\" ``liftM`` 'queryParam' \"id\" 29 | return $ 'ok' \"text/json\" $ fromString $ 30 | \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\" 31 | F.'put' \"\/user\/:id\" $ do 32 | ... 33 | @ 34 | 35 | With @hails@, you can directly run this: 36 | 37 | > hails --app=SimpleFrank 38 | 39 | And, with @curl@, you can now checkout your page: 40 | 41 | > $ curl localhost:8080/users 42 | > Welcome Home "localhost" 43 | > 44 | > $ curl localhost:8080/users/123 45 | > {"myid": "123"} 46 | > 47 | > $ ... 48 | 49 | -} 50 | module Hails.Web.Frank 51 | ( get 52 | , post 53 | , put 54 | , delete 55 | , options 56 | ) where 57 | 58 | import Network.HTTP.Types 59 | import Hails.Web.Router 60 | import qualified Data.ByteString as S 61 | 62 | -- | Helper method 63 | frankMethod :: Routeable r => StdMethod -> S.ByteString -> r -> Route 64 | frankMethod method pattern = routeMethod method . routePattern pattern 65 | 66 | -- | Matches the GET method on the given URL pattern 67 | get :: Routeable r => S.ByteString -> r -> Route 68 | get = frankMethod GET 69 | 70 | -- | Matches the POST method on the given URL pattern 71 | post :: Routeable r => S.ByteString -> r -> Route 72 | post = frankMethod POST 73 | 74 | -- | Matches the PUT method on the given URL pattern 75 | put :: Routeable r => S.ByteString -> r -> Route 76 | put = frankMethod PUT 77 | 78 | -- | Matches the DELETE method on the given URL pattern 79 | delete :: Routeable r => S.ByteString -> r -> Route 80 | delete = frankMethod DELETE 81 | 82 | -- | Matches the OPTIONS method on the given URL pattern 83 | options :: Routeable r => S.ByteString -> r -> Route 84 | options = frankMethod OPTIONS 85 | -------------------------------------------------------------------------------- /Hails/Web/REST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} 3 | {- | 4 | REST is a DSL for creating routes using RESTful HTTP verbs. 5 | See 6 | 7 | For example, an app handling users may define a REST controller as: 8 | 9 | @ 10 | module SimpleREST (server) where 11 | 12 | import "Data.String" 13 | import "Data.Maybe" 14 | import "Control.Monad" 15 | 16 | import "LIO" 17 | import "Hails.HttpServer.Types" 18 | import "Hails.Web" 19 | import qualified "Hails.Web.REST" as REST 20 | 21 | server :: 'Application' 22 | server = 'mkRouter' $ 'routeName' \"users\" $ do 23 | REST.'index' $ do 24 | req \<- 'request' '>>=' unlabel 25 | return $ 'okHtml' $ 'fromString' $ 26 | \"Welcome Home \" ++ (show $ 'serverName' req) 27 | REST.'show' $ do 28 | userId <- fromMaybe \"\" ``liftM`` 'queryParam' \"id\" 29 | return $ 'ok' \"text/json\" $ fromString $ 30 | \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\" 31 | ... 32 | @ 33 | 34 | With @hails@, you can directly run this: 35 | 36 | > hails --app=SimpleREST 37 | 38 | And, with @curl@, you can now checkout your page: 39 | 40 | > $ curl localhost:8080/users 41 | > Welcome Home "localhost" 42 | > 43 | > $ curl localhost:8080/users/123 44 | > {"myid": "123"} 45 | > 46 | > $ ... 47 | 48 | 49 | -} 50 | module Hails.Web.REST 51 | ( RESTController 52 | , index, show, create, update, delete 53 | , edit, new 54 | ) where 55 | 56 | import Prelude hiding (show, pi) 57 | 58 | import LIO.DCLabel 59 | 60 | import Control.Monad.Trans.State 61 | import Hails.Web.Responses 62 | import Hails.Web.Router 63 | import Network.HTTP.Types 64 | 65 | -- | Type used to encode a REST controller. 66 | data RESTControllerState = RESTControllerState 67 | { restIndex :: Route 68 | , restShow :: Route 69 | , restCreate :: Route 70 | , restUpdate :: Route 71 | , restDelete :: Route 72 | , restEdit :: Route 73 | , restNew :: Route 74 | } 75 | 76 | -- | Default state, returns @404@ for all verbs. 77 | defaultRESTControllerState :: RESTControllerState 78 | defaultRESTControllerState = RESTControllerState 79 | { restIndex = routeAll $ notFound 80 | , restShow = routeAll $ notFound 81 | , restCreate = routeAll $ notFound 82 | , restUpdate = routeAll $ notFound 83 | , restDelete = routeAll $ notFound 84 | , restEdit = routeAll $ notFound 85 | , restNew = routeAll $ notFound 86 | } 87 | 88 | instance Routeable RESTControllerState where 89 | runRoute controller = runRoute $ do 90 | routeMethod GET $ do 91 | routeTop $ restIndex controller 92 | routeName "new" $ restNew controller 93 | routeVar "id" $ do 94 | routeTop $ restShow controller 95 | routeName "edit" $ restEdit controller 96 | 97 | routeMethod POST $ routeTop $ restCreate controller 98 | 99 | routeMethod DELETE $ routeVar "id" $ restDelete controller 100 | 101 | routeMethod PUT $ routeVar "id" $ restUpdate controller 102 | 103 | -- | Monad used to encode a REST controller incrementally. 104 | type RESTControllerM a = StateT RESTControllerState DC a 105 | 106 | -- | Monad used to encode a REST controller incrementally. 107 | -- The return type is not used, hence always '()'. 108 | type RESTController = RESTControllerM () 109 | 110 | instance Routeable (RESTControllerM a) where 111 | runRoute controller = rt 112 | where rt pi eq conf req = do 113 | (_, st) <- runStateT controller defaultRESTControllerState 114 | runRoute st pi eq conf req 115 | 116 | 117 | -- |GET \/ 118 | index :: Routeable r => r -> RESTController 119 | index route = modify $ \controller -> 120 | controller { restIndex = routeAll route } 121 | 122 | -- |POST \/ 123 | create :: Routeable r => r -> RESTController 124 | create route = modify $ \controller -> 125 | controller { restCreate = routeAll route } 126 | 127 | -- |GET \/:id\/edit 128 | edit :: Routeable r => r -> RESTController 129 | edit route = modify $ \controller -> 130 | controller { restEdit = routeAll route } 131 | 132 | -- |GET \/new 133 | new :: Routeable r => r -> RESTController 134 | new route = modify $ \controller -> 135 | controller { restNew = routeAll route } 136 | 137 | -- |GET \/:id 138 | show :: Routeable r => r -> RESTController 139 | show route = modify $ \controller -> 140 | controller { restShow = routeAll route } 141 | 142 | -- |PUT \/:id 143 | update :: Routeable r => r -> RESTController 144 | update route = modify $ \controller -> 145 | controller { restUpdate = routeAll route } 146 | 147 | -- |DELETE \/:id 148 | delete :: Routeable r => r -> RESTController 149 | delete route = modify $ \controller -> 150 | controller { restDelete = routeAll route } 151 | 152 | -------------------------------------------------------------------------------- /Hails/Web/Responses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | -- | This module defines some convenience functions for creating responses. 4 | module Hails.Web.Responses 5 | ( ok, okHtml 6 | , movedTo, redirectTo 7 | , badRequest, requireBasicAuth, forbidden 8 | , notFound 9 | , serverError 10 | ) where 11 | 12 | import qualified Data.ByteString.Char8 as S8 13 | import qualified Data.ByteString.Lazy.Char8 as L8 14 | import Network.HTTP.Types 15 | import Hails.HttpServer 16 | 17 | -- | Type alias for 'S8.ByteString' 18 | type ContentType = S8.ByteString 19 | 20 | -- | Creates a 200 (OK) 'Response' with the given content-type and resposne 21 | -- body 22 | ok :: ContentType -> L8.ByteString -> Response 23 | ok contentType body = 24 | Response status200 [(hContentType, contentType)] body 25 | 26 | -- | Helper to make responses with content-type \"text/html\" 27 | mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response 28 | mkHtmlResponse stat hdrs = 29 | Response stat ((hContentType, S8.pack "text/html"):hdrs) 30 | 31 | -- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the 32 | -- given resposne body 33 | okHtml :: L8.ByteString -> Response 34 | okHtml body = 35 | mkHtmlResponse status200 [] body 36 | 37 | -- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to 38 | -- that URL. 39 | movedTo :: String -> Response 40 | movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html 41 | where html = L8.concat 42 | [L8.pack 43 | "\n\ 44 | \\n\ 45 | \301 Moved Permanently\n\ 46 | \\n\ 47 | \

Moved Permanently

\n\ 48 | \

The document has moved here\n\ 51 | \\n"] 52 | 53 | -- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL. 54 | redirectTo :: String -> Response 55 | redirectTo url = mkHtmlResponse status303 [(hLocation, S8.pack url)] html 56 | where html = L8.concat 57 | [L8.pack 58 | "\n\ 59 | \\n\ 60 | \303 See Other\n\ 61 | \\n\ 62 | \

See Other

\n\ 63 | \

The document has moved here\n\ 66 | \\n"] 67 | 68 | -- | Returns a 400 (Bad Request) 'Response'. 69 | badRequest :: Response 70 | badRequest = mkHtmlResponse status400 [] html 71 | where html = L8.concat 72 | [L8.pack 73 | "\n\ 74 | \\n\ 75 | \400 Bad Request\n\ 76 | \\n\ 77 | \

Bad Request

\n\ 78 | \

Your request could not be understood.

\n\ 79 | \\n"] 80 | 81 | -- | Returns a 401 (Authorization Required) 'Response' requiring basic 82 | -- authentication in the given realm. 83 | requireBasicAuth :: String -> Response 84 | requireBasicAuth realm = mkHtmlResponse status401 85 | [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html 86 | where html = L8.concat 87 | [L8.pack 88 | "\n\ 89 | \\n\ 90 | \401 Authorization Required\n\ 91 | \\n\ 92 | \

Authorization Required

\n\ 93 | \\n"] 94 | 95 | -- | Returns a 403 (Forbidden) 'Response'. 96 | forbidden :: Response 97 | forbidden = mkHtmlResponse status403 [] html 98 | where html = L8.concat 99 | [L8.pack 100 | "\n\ 101 | \\n\ 102 | \403 Forbidden\n\ 103 | \\n\ 104 | \

Forbidden

\n\ 105 | \

You don't have permission to access this page.

\n\ 106 | \\n"] 107 | 108 | -- | Returns a 404 (Not Found) 'Response'. 109 | notFound :: Response 110 | notFound = mkHtmlResponse status404 [] html 111 | where html = L8.concat 112 | [L8.pack 113 | "\n\ 114 | \\n\ 115 | \404 Not Found\n\ 116 | \\n\ 117 | \

Not Found

\n\ 118 | \

The requested URL was not found on this server.

\n\ 119 | \\n"] 120 | 121 | -- | Returns a 500 (Server Error) 'Response'. 122 | serverError :: Response 123 | serverError= mkHtmlResponse status500 [] html 124 | where html = L8.concat 125 | [L8.pack 126 | "\n\ 127 | \\n\ 128 | \500 Internal Server Error\n\ 129 | \\n\ 130 | \

Internal Server Error

\n\ 131 | \\n"] 132 | -------------------------------------------------------------------------------- /Hails/Web/Router.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {- | 4 | 5 | Conceptually, a route is function that, given an HTTP request, may return 6 | an action (something that would return a response for the client if run). 7 | Routes can be concatenated--where each route is evaluated until one 8 | matches--and nested. Routes are expressed through the 'Routeable' type class. 9 | 'runRoute' transforms an instance of 'Routeable' to a function from 'Request' 10 | to a monadic action (in the 'ResourceT' monad) that returns a 11 | 'Maybe' 'Response'. The return type was chosen to be monadic so routing 12 | decisions can depend on side-effects (e.g. a random number or counter for A/B 13 | testing, IP geolocation lookup etc'). 14 | 15 | -} 16 | 17 | module Hails.Web.Router 18 | ( 19 | -- * Example 20 | -- $Example 21 | Routeable(..) 22 | , mkRouter 23 | -- * Route Monad 24 | , Route, RouteM(..) 25 | -- * Common Routes 26 | , routeAll, routeHost, routeTop, routeMethod 27 | , routePattern, routeName, routeVar 28 | ) where 29 | 30 | import Prelude hiding (pi) 31 | import Control.Monad 32 | import Control.Applicative 33 | 34 | import LIO 35 | import LIO.DCLabel 36 | 37 | import qualified Data.ByteString as S 38 | import qualified Data.ByteString.Char8 as S8 39 | import Data.Monoid 40 | import Data.Text (Text) 41 | import qualified Data.Text as T 42 | import Hails.HttpServer 43 | import Hails.Web.Responses 44 | 45 | -- | Route handler is a fucntion from the path info, request 46 | -- configuration, and labeled request to a response. 47 | type RouteHandler = [Text] -- ^ Path info 48 | -> [(S8.ByteString, Maybe S8.ByteString)] -- ^ Extra query params 49 | -> RequestConfig -- ^ Request configuration 50 | -> DCLabeled Request -- ^ Labeled request 51 | -> DC (Maybe Response) 52 | 53 | {- | 54 | 'Routeable' types can be converted into a route function using 'runRoute'. 55 | If the route is matched it returns a 'Response', otherwise 'Nothing'. 56 | 57 | In general, 'Routeable's are data-dependant (on the 'Request'), but don't have 58 | to be. For example, 'Application' is an instance of 'Routeable' that always 59 | returns a 'Response': 60 | 61 | @ 62 | instance Routeable Application where 63 | runRoute app req = app req >>= return . Just 64 | @ 65 | 66 | -} 67 | class Routeable r where 68 | -- | Run a route 69 | runRoute :: r -> RouteHandler 70 | 71 | -- | Converts any 'Routeable' into an 'Application' that can be passed 72 | -- directly to a WAI server. 73 | mkRouter :: Routeable r => r -> Application 74 | mkRouter route conf lreq = do 75 | req <- liftLIO $ unlabel lreq 76 | let pi = pathInfo req 77 | mapp <- runRoute route pi [] conf lreq 78 | case mapp of 79 | Just resp -> return resp 80 | Nothing -> return notFound 81 | 82 | 83 | instance Routeable Application where 84 | runRoute app _ _ conf req = fmap Just $ app conf req 85 | 86 | instance Routeable Response where 87 | runRoute resp _ _ _ _ = return . Just $ resp 88 | 89 | {- | 90 | The 'RouteM' type is a basic instance of 'Routeable' that simply holds 91 | the routing function and an arbitrary additional data parameter. In 92 | most cases this paramter is simply '()', hence we have a synonym for 93 | @'RouteM' '()'@ called 'Route'. The power is derived from the 94 | instances of 'Monad' and 'Monoid', which allow the simple construction 95 | of complex routing rules using either lists ('Monoid') or do-notation. 96 | Moreover, because of it's simple type, any 'Routeable' can be used as 97 | a 'Route' (using 'routeAll' or by applying it to 'runRoute'), making 98 | it possible to leverage the monadic or monoid syntax for any 99 | 'Routeable'. 100 | 101 | Commonly, route functions that construct a 'Route' only inspect the 'Request' 102 | and other parameters. For example, 'routeHost' looks at the hostname: 103 | 104 | @ 105 | routeHost :: Routeable r => S.ByteString -> r -> Route 106 | routeHost host route = Route func () 107 | where func req = if host == serverName req 108 | then runRoute route req 109 | else return Nothing 110 | @ 111 | 112 | However, because the result of a route is in the 113 | 'ResourceT' monad, routes have all the power of an 'Application' and can make 114 | state-dependant decisions. For example, it is trivial to implement a route that 115 | succeeds for every other request (perhaps for A/B testing): 116 | 117 | @ 118 | routeEveryOther :: (Routeable r1, Routeable r2) 119 | => MVar Int -> r1 -> r2 -> Route 120 | routeEveryOther counter r1 r2 = Route func () 121 | where func req = do 122 | i <- liftIO . modifyMVar $ \i -> 123 | let i' = i+1 124 | in return (i', i') 125 | if i `mod` 2 == 0 126 | then runRoute r1 req 127 | else runRoute r2 req 128 | @ 129 | 130 | -} 131 | data RouteM a = Route RouteHandler a 132 | 133 | -- | Synonym for 'RouteM', the common case where the data parameter is '()'. 134 | type Route = RouteM () 135 | 136 | -- | Create a route given the route handler. 137 | mroute :: RouteHandler -> Route 138 | mroute handler = Route handler () 139 | 140 | instance Monad RouteM where 141 | return a = Route (const . const . const . const $ return Nothing) a 142 | (Route rtA valA) >>= fn = 143 | let (Route rtB valB) = fn valA 144 | in Route (\pi eq conf req -> do 145 | resA <- rtA pi eq conf req 146 | case resA of 147 | Nothing -> rtB pi eq conf req 148 | Just _ -> return resA) valB 149 | 150 | instance Functor RouteM where 151 | fmap f x = pure f <*> x 152 | 153 | instance Applicative RouteM where 154 | pure = return 155 | (<*>) = ap 156 | 157 | instance Monoid Route where 158 | mempty = mroute $ const . const . const . const $ return Nothing 159 | mappend (Route a _) (Route b _) = mroute $ \pi eq conf req -> do 160 | c <- a pi eq conf req 161 | case c of 162 | Nothing -> b pi eq conf req 163 | Just _ -> return c 164 | 165 | instance Routeable (RouteM a) where 166 | runRoute (Route rtr _) pi eq conf req = rtr pi eq conf req 167 | 168 | -- | A route that always matches (useful for converting a 'Routeable' into a 169 | -- 'Route'). 170 | routeAll :: Routeable r => r -> Route 171 | routeAll = mroute . runRoute 172 | 173 | -- | Matches on the hostname from the 'Request'. The route only successeds on 174 | -- exact matches. 175 | routeHost :: Routeable r => S.ByteString -> r -> Route 176 | routeHost host route = mroute $ \pi eq conf lreq -> do 177 | req <- unlabel lreq 178 | if host == serverName req 179 | then runRoute route pi eq conf lreq 180 | else return Nothing 181 | 182 | -- | Matches if the path is empty. Note that this route checks that 'pathInfo' 183 | -- is empty, so it works as expected when nested under namespaces or other 184 | -- routes that pop the 'pathInfo' list. 185 | routeTop :: Routeable r => r -> Route 186 | routeTop route = mroute $ \pi eq conf lreq -> do 187 | if null pi || (T.null . head $ pi) 188 | then runRoute route pi eq conf lreq 189 | else return Nothing 190 | 191 | -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT') 192 | routeMethod :: Routeable r => StdMethod -> r -> Route 193 | routeMethod method route = mroute $ \pi eq conf lreq -> do 194 | req <- unlabel lreq 195 | if renderStdMethod method == requestMethod req then 196 | runRoute route pi eq conf lreq 197 | else return Nothing 198 | 199 | -- | Routes the given URL pattern. Patterns can include 200 | -- directories as well as variable patterns (prefixed with @:@) to be added 201 | -- to 'queryString' (see 'routeVar') 202 | -- 203 | -- * \/posts\/:id 204 | -- 205 | -- * \/posts\/:id\/new 206 | -- 207 | -- * \/:date\/posts\/:category\/new 208 | -- 209 | routePattern :: Routeable r => S.ByteString -> r -> Route 210 | routePattern pattern route = 211 | let patternParts = map T.unpack $ decodePathSegments pattern 212 | in foldr mkRoute (routeTop route) patternParts 213 | where mkRoute (':':varName) = routeVar (S8.pack varName) 214 | mkRoute varName = routeName (S8.pack varName) 215 | 216 | -- | Matches if the first directory in the path matches the given 'ByteString' 217 | routeName :: Routeable r => S.ByteString -> r -> Route 218 | routeName name route = mroute $ \pi eq conf lreq -> do 219 | if (not . null $ pi) && S8.unpack name == (T.unpack . head $ pi) 220 | then runRoute route (tail pi) eq conf lreq 221 | else return Nothing 222 | 223 | -- | Always matches if there is at least one directory in 'pathInfo' but and 224 | -- adds a parameter to 'queryString' where the key is the supplied 225 | -- variable name and the value is the directory consumed from the path. 226 | routeVar :: Routeable r => S.ByteString -> r -> Route 227 | routeVar varName route = mroute $ \pi eq conf lreq -> 228 | if null pi 229 | then return Nothing 230 | else let varVal = S8.pack . T.unpack . head $ pi 231 | neqp = (varName, Just varVal):eq 232 | in runRoute route (tail pi) neqp conf lreq 233 | 234 | {- $Example 235 | #example# 236 | 237 | The most basic 'Routeable' types are 'Application' and 'Response'. Reaching 238 | either of these types marks a termination in the routing lookup. This module 239 | exposes a monadic type 'Route' which makes it easy to create routing logic 240 | in a DSL-like fashion. 241 | 242 | 'Route's are concatenated using the '>>' operator (or using do-notation). 243 | In the end, any 'Routeable', including a 'Route' is converted to an 244 | 'Application' and passed to the server using 'mkRouter': 245 | 246 | @ 247 | 248 | mainAction :: Application 249 | mainAction req = ... 250 | 251 | signinForm :: Application 252 | signinForm req = ... 253 | 254 | login :: Application 255 | login req = ... 256 | 257 | updateProfile :: Application 258 | updateProfile req = ... 259 | 260 | main :: IO () 261 | main = runSettings defaultSettings $ mkRouter $ do 262 | routeTop mainAction 263 | routeName \"sessions\" $ do 264 | routeMethod GET signinForm 265 | routeMethod POST login 266 | routeMethod PUT $ routePattern \"users/:id\" updateProfile 267 | routeAll $ responseLBS status404 [] \"Are you in the right place?\" 268 | @ 269 | 270 | -} 271 | 272 | -------------------------------------------------------------------------------- /Hails/Web/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Trustworthy #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-| 4 | 5 | This module exports a type corresponding to user\'s in Hails 6 | and some helper functions. 7 | 8 | -} 9 | module Hails.Web.User ( 10 | UserName 11 | , getHailsUser 12 | , withUserOrDoAuth 13 | ) where 14 | 15 | 16 | import qualified Data.ByteString.Char8 as S8 17 | import qualified Data.Text as T 18 | import Data.Text (Text) 19 | import Hails.Web.Controller 20 | import Hails.HttpServer 21 | 22 | -- | User name. 23 | type UserName = Text 24 | 25 | -- | Execute action with the current user's name. Otherwise, request 26 | -- that the user authenticate. 27 | withUserOrDoAuth :: (UserName -> Controller Response) 28 | -> Controller Response 29 | withUserOrDoAuth act = getHailsUser >>= \muser -> 30 | maybe (return reqLogin) act muser 31 | where reqLogin = Response status200 [("X-Hails-Login", "Yes")] "" 32 | 33 | -- | Get the current user. 34 | getHailsUser :: Controller (Maybe UserName) 35 | getHailsUser = do 36 | fmap (fmap (T.pack . S8.unpack)) $ requestHeader "x-hails-user" 37 | 38 | 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2011-2014 Hails team n 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Installation ## 2 | 3 | You can compile Hails as usual with `cabal-sandbox`: 4 | 5 | $ cabal sandbox init 6 | $ cabal install hails 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main :: IO () 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /examples/SimpleApp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Safe #-} 2 | module SimpleApp (server) where 3 | 4 | import Hails.HttpServer 5 | 6 | import qualified Data.ByteString.Lazy.Char8 as L8 7 | 8 | server :: Application 9 | server _ _ = return $ 10 | Response ok200 [] (L8.pack "w00t") 11 | -------------------------------------------------------------------------------- /examples/SimpleFrank.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleFrank (server) where 3 | 4 | import Data.String 5 | import Data.Maybe 6 | import Control.Monad 7 | 8 | import LIO 9 | import Hails.HttpServer.Types 10 | import Hails.Web 11 | import qualified Hails.Web.Frank as Frank 12 | 13 | server :: Application 14 | server = mkRouter $ do 15 | routeTop (redirectTo "/users") 16 | Frank.get "/users" $ do 17 | req <- request >>= liftLIO . unlabel 18 | return $ okHtml $ fromString $ 19 | "Welcome to " ++ (show $ serverName req) ++ 20 | "
Go to url: /users/:id/" 21 | Frank.get "/users/:id" $ do 22 | userId <- fromMaybe "" `liftM` queryParam "id" 23 | return $ ok "text/json" $ fromString $ 24 | "{\"myid\": " ++ (show userId) ++ "}" 25 | -------------------------------------------------------------------------------- /examples/SimpleFullExample/SimpleApp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleApp (server) where 3 | 4 | import Data.Maybe 5 | import qualified Data.ByteString.Char8 as S8 6 | import qualified Data.ByteString.Lazy.Char8 as L8 7 | 8 | import Control.Monad 9 | 10 | import LIO 11 | import Hails.HttpServer 12 | import Hails.Database 13 | 14 | import SimplePolicyModule 15 | server :: Application 16 | server _ lreq = do 17 | req <- unlabel lreq 18 | resp <- case pathInfo req of 19 | ("insert":_) -> do 20 | let es :: [(String,String)] 21 | es = map (\(k,mv) -> (S8.unpack k,S8.unpack $ fromJust mv)) $ 22 | filter (isJust . snd) $ queryString req 23 | withStorePolicyModule $ forM_ es $ \(k,v) -> 24 | insert_ "store" (["key" -: k, "val" -: v] :: HsonDocument) 25 | return $ "Inserted" ++ show es 26 | ("fetch":_) -> do 27 | let es = map (S8.unpack . fst) $ 28 | filter (isNothing . snd) $ queryString req 29 | lmrs <- withStorePolicyModule $ forM es $ \k -> 30 | findOne (select ["key" -: k] "store") 31 | rs <- forM (filter isJust lmrs) (unlabel . fromJust) 32 | return $ "Fetched" ++ show rs 33 | [] -> return $ "Welcome to the simple key-value store!\n" ++ use 34 | _ -> return $ "Unrecognized query. Expecting:\n" ++ use 35 | return $ Response ok200 [] (L8.pack resp) 36 | where use = " Insert: /insert?key1=val1&key2=val2&..\n" 37 | ++ " Fetch: /fetch?key1&key2\n" 38 | -------------------------------------------------------------------------------- /examples/SimpleFullExample/SimpleApp2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleApp2 (server) where 3 | 4 | import Prelude hiding (lookup) 5 | import Data.String 6 | import Control.Monad 7 | import qualified Data.ByteString.Char8 as S8 8 | import qualified Data.ByteString.Lazy.Char8 as L8 9 | 10 | import LIO 11 | import Hails.Web 12 | import qualified Hails.Web.Frank as Frank 13 | import Hails.HttpServer 14 | import Hails.Database 15 | 16 | import SimplePolicyModule 17 | 18 | server :: Application 19 | server = mkRouter $ do 20 | Frank.get "/" $ do 21 | req <- request >>= liftLIO . unlabel 22 | return $ okHtml $ fromString $ 23 | "Welcome to " ++ (show $ serverName req) ++ 24 | "

Store:

"++ 25 | ""++ 26 | "

Fetch:

"++ 27 | "" 28 | Frank.post "/store" $ do 29 | doc <- include ["key","val"] `liftM` hsonRequest 30 | if length doc /= 2 31 | then respond badRequest 32 | else do liftLIO $ withStorePolicyModule $ insert "store" doc 33 | respond $ redirectTo $ "/store/" ++ ("key" `at` doc) 34 | Frank.get "/store" $ do 35 | mk <- (fmap S8.unpack) `liftM` queryParam "key" 36 | respond $ maybe badRequest (\k -> redirectTo $ "/store/" ++ k) mk 37 | Frank.get "/store/:key" $ do 38 | mk <- queryParam "key" 39 | case mk of 40 | Nothing -> return notFound 41 | Just k -> do 42 | mlv <- liftLIO $ withStorePolicyModule $ do 43 | findOne $ select ["key" -: k] "store" 44 | case mlv of 45 | Nothing -> return notFound 46 | Just lv -> do v <- liftLIO $ unlabel lv 47 | return $ okHtml $ L8.pack $ "val" `at` v 48 | where hsonRequest :: Controller Document 49 | hsonRequest = request >>= labeledRequestToHson >>= (liftLIO . unlabel) 50 | -------------------------------------------------------------------------------- /examples/SimpleFullExample/SimplePolicyModule.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, 2 | ScopedTypeVariables, 3 | OverloadedStrings #-} 4 | 5 | module SimplePolicyModule ( 6 | StorePolicyModule 7 | , withStorePolicyModule 8 | ) where 9 | 10 | import Data.Typeable 11 | 12 | import LIO 13 | import LIO.DCLabel 14 | import Hails.Database 15 | import Hails.PolicyModule 16 | import Hails.PolicyModule.DSL 17 | 18 | data StorePolicyModule = StorePolicyModuleTCB DCPriv 19 | deriving Typeable 20 | 21 | instance PolicyModule StorePolicyModule where 22 | initPolicyModule priv = do 23 | setPolicy priv $ do 24 | database $ do 25 | readers ==> unrestricted 26 | writers ==> unrestricted 27 | admins ==> this 28 | collection "store" $ do 29 | access $ do 30 | readers ==> unrestricted 31 | writers ==> unrestricted 32 | clearance $ do 33 | secrecy ==> this 34 | integrity ==> unrestricted 35 | document $ \_ -> do 36 | readers ==> unrestricted 37 | writers ==> unrestricted 38 | field "coord" key 39 | return $ StorePolicyModuleTCB priv 40 | where this = privDesc priv 41 | 42 | withStorePolicyModule :: DBAction a -> DC a 43 | withStorePolicyModule act = withPolicyModule (\(_ :: StorePolicyModule) -> act) 44 | -------------------------------------------------------------------------------- /examples/SimpleFullExample/database.conf: -------------------------------------------------------------------------------- 1 | ("main:SimplePolicyModule.StorePolicyModule","simple_pm_db") 2 | -------------------------------------------------------------------------------- /examples/SimpleFullExample/static/fetch.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | key-value store 4 | 5 |
6 | 9 | 10 |
11 | 12 | 13 | -------------------------------------------------------------------------------- /examples/SimpleFullExample/static/store.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | key-value store 4 | 5 |
6 | 9 | 12 | 13 |
14 | 15 | 16 | -------------------------------------------------------------------------------- /examples/SimpleParams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleParams (server) where 3 | 4 | import qualified Data.ByteString.Lazy.Char8 as L8 5 | 6 | import LIO 7 | import LIO.DCLabel 8 | import Hails.HttpServer 9 | import Hails.Data.Hson 10 | 11 | server :: Application 12 | server _ lreq = do 13 | req <- liftLIO $ unlabel lreq 14 | ldoc <- labeledRequestToHson lreq 15 | doc <- liftLIO $ unlabel ldoc 16 | return $ case pathInfo req of 17 | ("login":_) -> Response temporaryRedirect307 18 | [("x-hails-login",""),(hLocation,"/")] "" 19 | _ -> Response ok200 [] $ topHtml (labelOf lreq, req) (labelOf ldoc, doc) 20 | 21 | topHtml :: (DCLabel, Request) -> (DCLabel, Document) -> L8.ByteString 22 | topHtml (lr, req) (ld, doc) = L8.pack $ 23 | "\ 24 | \ Simple post form example\ 25 | \ \ 26 | \

Login

\ 27 | \ login\ 28 | \

Basic input

\ 29 | \
\ 30 | \
\ 31 | \ \ 32 | \ \ 33 | \ \ 34 | \ \ 35 | \ \ 36 | \ \ 37 | \
\ 38 | \

File upload

\ 39 | \
\ 40 | \
\ 41 | \ \ 42 | \ \ 43 | \ \ 44 | \
\ 45 | \
" 46 | ++"

Request

Label:" ++ show lr ++ "
" 47 | ++"
" ++ show req ++ "
" 48 | ++"

Document

Label:" ++ show ld ++ "
" 49 | ++"
" ++ show doc ++ "
" 50 | ++ " \ 51 | \" 52 | -------------------------------------------------------------------------------- /examples/SimpleREST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleREST (server) where 3 | 4 | import Data.String 5 | import Data.Maybe 6 | import Control.Monad 7 | 8 | import LIO 9 | import Hails.HttpServer.Types 10 | import Hails.Web 11 | import qualified Hails.Web.REST as REST 12 | 13 | server :: Application 14 | server = mkRouter $ do 15 | routeTop (redirectTo "/users") 16 | routeName "users" $ do 17 | REST.index $ do 18 | req <- request >>= liftLIO . unlabel 19 | return $ okHtml $ fromString $ 20 | "Welcome to " ++ (show $ serverName req) ++ 21 | "
Go to url: /users/:id/" 22 | REST.show $ do 23 | userId <- fromMaybe "" `liftM` queryParam "id" 24 | return $ ok "text/json" $ fromString $ 25 | "{\"myid\": " ++ (show userId) ++ "}" 26 | -------------------------------------------------------------------------------- /examples/SimpleStatic/SimpleApp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleApp (server) where 3 | 4 | import Hails.HttpServer 5 | 6 | server :: Application 7 | server _ _ = do 8 | return $ Response ok200 [] topHtml 9 | 10 | topHtml = 11 | "\ 12 | \ \ 13 | \ Simple static file server\ 14 | \ \ 15 | \ \ 16 | \ \ 17 | \ \ 18 | \ \ 19 | \ Serving images from stock.xchng:\ 20 | \
\ 21 | \
\ 22 | \ \ 23 | \ \ 24 | \
\ 25 | \ \ 26 | \ \ 27 | \
\ 28 | \ \ 29 | \ \ 30 | \
\ 31 | \ \ 32 | \ \ 33 | \
\ 34 | \ \ 35 | \" 36 | -------------------------------------------------------------------------------- /examples/SimpleStatic/static/css/lightbox.css: -------------------------------------------------------------------------------- 1 | /* line 6, ../sass/lightbox.sass */ 2 | #lightboxOverlay { 3 | position: absolute; 4 | top: 0; 5 | left: 0; 6 | z-index: 9999; 7 | background-color: black; 8 | filter: progid:DXImageTransform.Microsoft.Alpha(Opacity=85); 9 | opacity: 0.85; 10 | display: none; 11 | } 12 | 13 | /* line 15, ../sass/lightbox.sass */ 14 | #lightbox { 15 | position: absolute; 16 | left: 0; 17 | width: 100%; 18 | z-index: 10000; 19 | text-align: center; 20 | line-height: 0; 21 | font-family: "lucida grande", tahoma, verdana, arial, sans-serif; 22 | font-weight: normal; 23 | } 24 | /* line 24, ../sass/lightbox.sass */ 25 | #lightbox img { 26 | width: auto; 27 | height: auto; 28 | } 29 | /* line 27, ../sass/lightbox.sass */ 30 | #lightbox a img { 31 | border: none; 32 | } 33 | 34 | /* line 30, ../sass/lightbox.sass */ 35 | .lb-outerContainer { 36 | position: relative; 37 | background-color: white; 38 | *zoom: 1; 39 | width: 250px; 40 | height: 250px; 41 | margin: 0 auto; 42 | -webkit-border-radius: 4px; 43 | -moz-border-radius: 4px; 44 | -ms-border-radius: 4px; 45 | -o-border-radius: 4px; 46 | border-radius: 4px; 47 | } 48 | /* line 38, ../../../../.rvm/gems/ruby-1.9.2-p290/gems/compass-0.12.1/frameworks/compass/stylesheets/compass/utilities/general/_clearfix.scss */ 49 | .lb-outerContainer:after { 50 | content: ""; 51 | display: table; 52 | clear: both; 53 | } 54 | 55 | /* line 39, ../sass/lightbox.sass */ 56 | .lb-container { 57 | padding: 10px; 58 | } 59 | 60 | /* line 42, ../sass/lightbox.sass */ 61 | .lb-loader { 62 | position: absolute; 63 | top: 40%; 64 | left: 0%; 65 | height: 25%; 66 | width: 100%; 67 | text-align: center; 68 | line-height: 0; 69 | } 70 | 71 | /* line 51, ../sass/lightbox.sass */ 72 | .lb-nav { 73 | position: absolute; 74 | top: 0; 75 | left: 0; 76 | height: 100%; 77 | width: 100%; 78 | z-index: 10; 79 | } 80 | 81 | /* line 59, ../sass/lightbox.sass */ 82 | .lb-container > .nav { 83 | left: 0; 84 | } 85 | 86 | /* line 62, ../sass/lightbox.sass */ 87 | .lb-nav a { 88 | outline: none; 89 | } 90 | 91 | /* line 65, ../sass/lightbox.sass */ 92 | .lb-prev, .lb-next { 93 | width: 49%; 94 | height: 100%; 95 | background-image: url("data:image/gif;base64,R0lGODlhAQABAIAAAAAAAP///yH5BAEAAAAALAAAAAABAAEAAAIBRAA7"); 96 | /* Trick IE into showing hover */ 97 | display: block; 98 | } 99 | 100 | /* line 72, ../sass/lightbox.sass */ 101 | .lb-prev { 102 | left: 0; 103 | float: left; 104 | } 105 | 106 | /* line 76, ../sass/lightbox.sass */ 107 | .lb-next { 108 | right: 0; 109 | float: right; 110 | } 111 | 112 | /* line 81, ../sass/lightbox.sass */ 113 | .lb-prev:hover { 114 | background: url(../static/images/prev.png) left 48% no-repeat; 115 | } 116 | 117 | /* line 85, ../sass/lightbox.sass */ 118 | .lb-next:hover { 119 | background: url(../static/images/next.png) right 48% no-repeat; 120 | } 121 | 122 | /* line 88, ../sass/lightbox.sass */ 123 | .lb-dataContainer { 124 | margin: 0 auto; 125 | padding-top: 5px; 126 | *zoom: 1; 127 | width: 100%; 128 | -moz-border-radius-bottomleft: 4px; 129 | -webkit-border-bottom-left-radius: 4px; 130 | -ms-border-bottom-left-radius: 4px; 131 | -o-border-bottom-left-radius: 4px; 132 | border-bottom-left-radius: 4px; 133 | -moz-border-radius-bottomright: 4px; 134 | -webkit-border-bottom-right-radius: 4px; 135 | -ms-border-bottom-right-radius: 4px; 136 | -o-border-bottom-right-radius: 4px; 137 | border-bottom-right-radius: 4px; 138 | } 139 | /* line 38, ../../../../.rvm/gems/ruby-1.9.2-p290/gems/compass-0.12.1/frameworks/compass/stylesheets/compass/utilities/general/_clearfix.scss */ 140 | .lb-dataContainer:after { 141 | content: ""; 142 | display: table; 143 | clear: both; 144 | } 145 | 146 | /* line 95, ../sass/lightbox.sass */ 147 | .lb-data { 148 | padding: 0 10px; 149 | color: #bbbbbb; 150 | } 151 | /* line 98, ../sass/lightbox.sass */ 152 | .lb-data .lb-details { 153 | width: 85%; 154 | float: left; 155 | text-align: left; 156 | line-height: 1.1em; 157 | } 158 | /* line 103, ../sass/lightbox.sass */ 159 | .lb-data .lb-caption { 160 | font-size: 13px; 161 | font-weight: bold; 162 | line-height: 1em; 163 | } 164 | /* line 107, ../sass/lightbox.sass */ 165 | .lb-data .lb-number { 166 | display: block; 167 | clear: left; 168 | padding-bottom: 1em; 169 | font-size: 11px; 170 | } 171 | /* line 112, ../sass/lightbox.sass */ 172 | .lb-data .lb-close { 173 | width: 35px; 174 | float: right; 175 | padding-bottom: 0.7em; 176 | outline: none; 177 | } 178 | /* line 117, ../sass/lightbox.sass */ 179 | .lb-data .lb-close:hover { 180 | cursor: pointer; 181 | } 182 | -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/bg-checker.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/bg-checker.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/box.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/box.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/bullet.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/bullet.gif -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/close.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/close.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/donate.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/donate.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/favicon.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/favicon.gif -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/loading.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/loading.gif -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/next.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/next.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/nyc.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/nyc.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/paris.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/paris.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/prev.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/prev.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/sf.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/sf.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/speech-bubbles.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/speech-bubbles.png -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/thumb.nyc.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/thumb.nyc.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/thumb.paris.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/thumb.paris.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/thumb.sf.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/thumb.sf.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/thumb.tokyo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/thumb.tokyo.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/images/tokyo.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/SimpleStatic/static/images/tokyo.jpg -------------------------------------------------------------------------------- /examples/SimpleStatic/static/js/jquery.smooth-scroll.min.js: -------------------------------------------------------------------------------- 1 | /*! 2 | * jQuery Smooth Scroll Plugin v1.4.5 3 | * 4 | * Date: Sun Mar 11 18:17:42 2012 EDT 5 | * Requires: jQuery v1.3+ 6 | * 7 | * Copyright 2012, Karl Swedberg 8 | * Dual licensed under the MIT and GPL licenses (just like jQuery): 9 | * http://www.opensource.org/licenses/mit-license.php 10 | * http://www.gnu.org/licenses/gpl.html 11 | * 12 | * 13 | * 14 | * 15 | */ 16 | (function(b){function m(c){return c.replace(/(:|\.)/g,"\\$1")}var n=function(c){var e=[],a=false,d=c.dir&&c.dir=="left"?"scrollLeft":"scrollTop";this.each(function(){if(!(this==document||this==window)){var g=b(this);if(g[d]()>0)e.push(this);else{g[d](1);a=g[d]()>0;g[d](0);a&&e.push(this)}}});if(c.el==="first"&&e.length)e=[e.shift()];return e},o="ontouchend"in document;b.fn.extend({scrollable:function(c){return this.pushStack(n.call(this,{dir:c}))},firstScrollable:function(c){return this.pushStack(n.call(this, 17 | {el:"first",dir:c}))},smoothScroll:function(c){c=c||{};var e=b.extend({},b.fn.smoothScroll.defaults,c),a=b.smoothScroll.filterPath(location.pathname);this.die("click.smoothscroll").live("click.smoothscroll",function(d){var g={},i=b(this),f=location.hostname===this.hostname||!this.hostname,h=e.scrollTarget||(b.smoothScroll.filterPath(this.pathname)||a)===a,k=m(this.hash),j=true;if(!e.scrollTarget&&(!f||!h||!k))j=false;else{f=e.exclude;h=0;for(var l=f.length;j&&h", { 89 | id: 'lightboxOverlay' 90 | }).after($('
', { 91 | id: 'lightbox' 92 | }).append($('
', { 93 | "class": 'lb-outerContainer' 94 | }).append($('
', { 95 | "class": 'lb-container' 96 | }).append($('', { 97 | "class": 'lb-image' 98 | }), $('
', { 99 | "class": 'lb-nav' 100 | }).append($('', { 101 | "class": 'lb-prev' 102 | }), $('', { 103 | "class": 'lb-next' 104 | })), $('
', { 105 | "class": 'lb-loader' 106 | }).append($('', { 107 | "class": 'lb-cancel' 108 | }).append($('', { 109 | src: this.options.fileLoadingImage 110 | }))))), $('
', { 111 | "class": 'lb-dataContainer' 112 | }).append($('
', { 113 | "class": 'lb-data' 114 | }).append($('
', { 115 | "class": 'lb-details' 116 | }).append($('', { 117 | "class": 'lb-caption' 118 | }), $('', { 119 | "class": 'lb-number' 120 | })), $('
', { 121 | "class": 'lb-closeContainer' 122 | }).append($('', { 123 | "class": 'lb-close' 124 | }).append($('', { 125 | src: this.options.fileCloseImage 126 | }))))))).appendTo($('body')); 127 | $('#lightboxOverlay').hide().on('click', function(e) { 128 | _this.end(); 129 | return false; 130 | }); 131 | $lightbox = $('#lightbox'); 132 | $lightbox.hide().on('click', function(e) { 133 | if ($(e.target).attr('id') === 'lightbox') _this.end(); 134 | return false; 135 | }); 136 | $lightbox.find('.lb-outerContainer').on('click', function(e) { 137 | if ($(e.target).attr('id') === 'lightbox') _this.end(); 138 | return false; 139 | }); 140 | $lightbox.find('.lb-prev').on('click', function(e) { 141 | _this.changeImage(_this.currentImageIndex - 1); 142 | return false; 143 | }); 144 | $lightbox.find('.lb-next').on('click', function(e) { 145 | _this.changeImage(_this.currentImageIndex + 1); 146 | return false; 147 | }); 148 | $lightbox.find('.lb-loader, .lb-close').on('click', function(e) { 149 | _this.end(); 150 | return false; 151 | }); 152 | }; 153 | 154 | Lightbox.prototype.start = function($link) { 155 | var $lightbox, $window, a, i, imageNumber, left, top, _len, _ref; 156 | $(window).on("resize", this.sizeOverlay); 157 | $('select, object, embed').css({ 158 | visibility: "hidden" 159 | }); 160 | $('#lightboxOverlay').width($(document).width()).height($(document).height()).fadeIn(this.options.fadeDuration); 161 | this.album = []; 162 | imageNumber = 0; 163 | if ($link.attr('rel') === 'lightbox') { 164 | this.album.push({ 165 | link: $link.attr('href'), 166 | title: $link.attr('title') 167 | }); 168 | } else { 169 | _ref = $($link.prop("tagName") + '[rel="' + $link.attr('rel') + '"]'); 170 | for (i = 0, _len = _ref.length; i < _len; i++) { 171 | a = _ref[i]; 172 | this.album.push({ 173 | link: $(a).attr('href'), 174 | title: $(a).attr('title') 175 | }); 176 | if ($(a).attr('href') === $link.attr('href')) imageNumber = i; 177 | } 178 | } 179 | $window = $(window); 180 | top = $window.scrollTop() + $window.height() / 10; 181 | left = $window.scrollLeft(); 182 | $lightbox = $('#lightbox'); 183 | $lightbox.css({ 184 | top: top + 'px', 185 | left: left + 'px' 186 | }).fadeIn(this.options.fadeDuration); 187 | this.changeImage(imageNumber); 188 | }; 189 | 190 | Lightbox.prototype.changeImage = function(imageNumber) { 191 | var $image, $lightbox, preloader, 192 | _this = this; 193 | this.disableKeyboardNav(); 194 | $lightbox = $('#lightbox'); 195 | $image = $lightbox.find('.lb-image'); 196 | this.sizeOverlay(); 197 | $('#lightboxOverlay').fadeIn(this.options.fadeDuration); 198 | $('.loader').fadeIn('slow'); 199 | $lightbox.find('.lb-image, .lb-nav, .lb-prev, .lb-next, .lb-dataContainer, .lb-numbers, .lb-caption').hide(); 200 | $lightbox.find('.lb-outerContainer').addClass('animating'); 201 | preloader = new Image; 202 | preloader.onload = function() { 203 | $image.attr('src', _this.album[imageNumber].link); 204 | $image.width = preloader.width; 205 | $image.height = preloader.height; 206 | return _this.sizeContainer(preloader.width, preloader.height); 207 | }; 208 | preloader.src = this.album[imageNumber].link; 209 | this.currentImageIndex = imageNumber; 210 | }; 211 | 212 | Lightbox.prototype.sizeOverlay = function() { 213 | return $('#lightboxOverlay').width($(document).width()).height($(document).height()); 214 | }; 215 | 216 | Lightbox.prototype.sizeContainer = function(imageWidth, imageHeight) { 217 | var $container, $lightbox, $outerContainer, containerBottomPadding, containerLeftPadding, containerRightPadding, containerTopPadding, newHeight, newWidth, oldHeight, oldWidth, 218 | _this = this; 219 | $lightbox = $('#lightbox'); 220 | $outerContainer = $lightbox.find('.lb-outerContainer'); 221 | oldWidth = $outerContainer.outerWidth(); 222 | oldHeight = $outerContainer.outerHeight(); 223 | $container = $lightbox.find('.lb-container'); 224 | containerTopPadding = parseInt($container.css('padding-top'), 10); 225 | containerRightPadding = parseInt($container.css('padding-right'), 10); 226 | containerBottomPadding = parseInt($container.css('padding-bottom'), 10); 227 | containerLeftPadding = parseInt($container.css('padding-left'), 10); 228 | newWidth = imageWidth + containerLeftPadding + containerRightPadding; 229 | newHeight = imageHeight + containerTopPadding + containerBottomPadding; 230 | if (newWidth !== oldWidth && newHeight !== oldHeight) { 231 | $outerContainer.animate({ 232 | width: newWidth, 233 | height: newHeight 234 | }, this.options.resizeDuration, 'swing'); 235 | } else if (newWidth !== oldWidth) { 236 | $outerContainer.animate({ 237 | width: newWidth 238 | }, this.options.resizeDuration, 'swing'); 239 | } else if (newHeight !== oldHeight) { 240 | $outerContainer.animate({ 241 | height: newHeight 242 | }, this.options.resizeDuration, 'swing'); 243 | } 244 | setTimeout(function() { 245 | $lightbox.find('.lb-dataContainer').width(newWidth); 246 | $lightbox.find('.lb-prevLink').height(newHeight); 247 | $lightbox.find('.lb-nextLink').height(newHeight); 248 | _this.showImage(); 249 | }, this.options.resizeDuration); 250 | }; 251 | 252 | Lightbox.prototype.showImage = function() { 253 | var $lightbox; 254 | $lightbox = $('#lightbox'); 255 | $lightbox.find('.lb-loader').hide(); 256 | $lightbox.find('.lb-image').fadeIn('slow'); 257 | this.updateNav(); 258 | this.updateDetails(); 259 | this.preloadNeighboringImages(); 260 | this.enableKeyboardNav(); 261 | }; 262 | 263 | Lightbox.prototype.updateNav = function() { 264 | var $lightbox; 265 | $lightbox = $('#lightbox'); 266 | $lightbox.find('.lb-nav').show(); 267 | if (this.currentImageIndex > 0) $lightbox.find('.lb-prev').show(); 268 | if (this.currentImageIndex < this.album.length - 1) { 269 | $lightbox.find('.lb-next').show(); 270 | } 271 | }; 272 | 273 | Lightbox.prototype.updateDetails = function() { 274 | var $lightbox, 275 | _this = this; 276 | $lightbox = $('#lightbox'); 277 | if (typeof this.album[this.currentImageIndex].title !== 'undefined' && this.album[this.currentImageIndex].title !== "") { 278 | $lightbox.find('.lb-caption').html(this.album[this.currentImageIndex].title).fadeIn('fast'); 279 | } 280 | if (this.album.length > 1) { 281 | $lightbox.find('.lb-number').html(this.options.labelImage + ' ' + (this.currentImageIndex + 1) + ' ' + this.options.labelOf + ' ' + this.album.length).fadeIn('fast'); 282 | } else { 283 | $lightbox.find('.lb-number').hide(); 284 | } 285 | $lightbox.find('.lb-outerContainer').removeClass('animating'); 286 | $lightbox.find('.lb-dataContainer').fadeIn(this.resizeDuration, function() { 287 | return _this.sizeOverlay(); 288 | }); 289 | }; 290 | 291 | Lightbox.prototype.preloadNeighboringImages = function() { 292 | var preloadNext, preloadPrev; 293 | if (this.album.length > this.currentImageIndex + 1) { 294 | preloadNext = new Image; 295 | preloadNext.src = this.album[this.currentImageIndex + 1].link; 296 | } 297 | if (this.currentImageIndex > 0) { 298 | preloadPrev = new Image; 299 | preloadPrev.src = this.album[this.currentImageIndex - 1].link; 300 | } 301 | }; 302 | 303 | Lightbox.prototype.enableKeyboardNav = function() { 304 | $(document).on('keyup.keyboard', $.proxy(this.keyboardAction, this)); 305 | }; 306 | 307 | Lightbox.prototype.disableKeyboardNav = function() { 308 | $(document).off('.keyboard'); 309 | }; 310 | 311 | Lightbox.prototype.keyboardAction = function(event) { 312 | var KEYCODE_ESC, KEYCODE_LEFTARROW, KEYCODE_RIGHTARROW, key, keycode; 313 | KEYCODE_ESC = 27; 314 | KEYCODE_LEFTARROW = 37; 315 | KEYCODE_RIGHTARROW = 39; 316 | keycode = event.keyCode; 317 | key = String.fromCharCode(keycode).toLowerCase(); 318 | if (keycode === KEYCODE_ESC || key.match(/x|o|c/)) { 319 | this.end(); 320 | } else if (key === 'p' || keycode === KEYCODE_LEFTARROW) { 321 | if (this.currentImageIndex !== 0) { 322 | this.changeImage(this.currentImageIndex - 1); 323 | } 324 | } else if (key === 'n' || keycode === KEYCODE_RIGHTARROW) { 325 | if (this.currentImageIndex !== this.album.length - 1) { 326 | this.changeImage(this.currentImageIndex + 1); 327 | } 328 | } 329 | }; 330 | 331 | Lightbox.prototype.end = function() { 332 | this.disableKeyboardNav(); 333 | $(window).off("resize", this.sizeOverlay); 334 | $('#lightbox').fadeOut(this.options.fadeDuration); 335 | $('#lightboxOverlay').fadeOut(this.options.fadeDuration); 336 | return $('select, object, embed').css({ 337 | visibility: "visible" 338 | }); 339 | }; 340 | 341 | return Lightbox; 342 | 343 | })(); 344 | 345 | $(function() { 346 | var lightbox, options; 347 | options = new LightboxOptions; 348 | return lightbox = new Lightbox(options); 349 | }); 350 | 351 | }).call(this); 352 | -------------------------------------------------------------------------------- /examples/SimpleWithClient/SimpleApp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module SimpleApp (server) where 3 | 4 | import qualified Data.ByteString.Lazy.Char8 as L8 5 | 6 | import LIO 7 | import LIO.DCLabel 8 | import Hails.HttpServer 9 | import Hails.Data.Hson 10 | 11 | server :: Application 12 | server _ lreq = do 13 | req <- unlabel lreq 14 | ldoc <- labeledRequestToHson lreq 15 | doc <- unlabel ldoc 16 | case pathInfo req of 17 | ("login":_) -> return $ 18 | Response temporaryRedirect307 [("x-hails-login",""),(hLocation,"/")] "" 19 | ("taint":_) -> do 20 | ccur <- getClearance 21 | let url = "http://www.google.com:80" :: String 22 | lbl = ccur `glb`dcLabel (toComponent url) dcTrue 23 | taint lbl 24 | return $ Response ok200 [] $ topHtml req 25 | _ -> return $ 26 | Response ok200 [] $ topHtml req 27 | 28 | topHtml :: Request -> L8.ByteString 29 | topHtml req = L8.pack $ 30 | "\ 31 | \ \ 32 | \Simple post form example\ 33 | \\ 34 | \ \ 35 | \

1. Login

\ 36 | \ login\ 37 | \

2. Taint

\ 38 | \ taint\ 39 | \ \ 40 | \ \ 41 | \ \ 42 | \ \ 43 | \ \ 44 | \ \ 45 | \ \ 46 | \

Remote images

\ 47 | \

Request

" 48 | ++"
" ++ show req ++ "
" 49 | ++ " \ 50 | \" 51 | -------------------------------------------------------------------------------- /examples/hails-rock/HailsRock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module HailsRock (server) where 4 | 5 | 6 | import Data.Maybe 7 | import qualified Data.ByteString.Char8 as S8 8 | import qualified Data.ByteString.Lazy.Char8 as L8 9 | 10 | import Control.Monad 11 | 12 | import LIO 13 | import LIO.DCLabel 14 | 15 | import Hails.Data.Hson 16 | import Hails.Database 17 | import Hails.Database.Structured 18 | import Hails.HttpServer 19 | import Hails.Web 20 | import qualified Hails.Web.Frank as Frank 21 | 22 | import HailsRock.MP 23 | import HailsRock.Views 24 | 25 | import LIO.TCB 26 | 27 | server :: Application 28 | server = mkRouter $ do 29 | Frank.get "/" $ do 30 | musr <- getHailsUser 31 | return $ respondHtml $ welcome musr 32 | 33 | -- List games 34 | Frank.get "/game" $ withUserOrDoAuth $ \usr -> do 35 | lreq <- request 36 | gs <- liftLIO . withHailsRockDB $ do 37 | games <- findAll $ select [] "games" 38 | plays' <- findAll $ select ["player" -: usr] "plays" 39 | let plays = map (Just . game) plays' 40 | return $ filter ((`notElem` plays) . gameId) games 41 | return $ respondHtml $ listGames usr gs 42 | 43 | -- Create a new game view 44 | Frank.get "/game/new" $ withUserOrDoAuth $ \usr -> do 45 | return $ respondHtml $ newGame usr 46 | 47 | -- Create a new game 48 | Frank.post "/game/create" $ withUserOrDoAuth $ \usr -> do 49 | lreq <- request 50 | liftLIO . withHailsRockDB $ do 51 | ldoc <- liftLIO $ labeledRequestToHson lreq 52 | _id <- insert "games" ldoc 53 | return $ redirectTo $ "/game/" ++ (show _id) 54 | 55 | -- Join a game 56 | Frank.get "/game/:id" $ withUserOrDoAuth $ \usr -> do 57 | (Just gid) <- queryParam "id" 58 | let _id = read . S8.unpack $ gid :: ObjectId 59 | (mgame, played) <- liftLIO . withHailsRockDB $ do 60 | mgame <- findBy "games" "_id" _id 61 | mplay <- findWhere $ select ["game" -: _id, "player" -: usr] "plays" 62 | return (mgame, isJust (mplay :: Maybe Play)) 63 | return $ case mgame of 64 | Nothing -> forbidden 65 | Just game -> respondHtml $ playGame usr game played 66 | 67 | -- Make the move 68 | Frank.post "/game/:id/play" $ withUserOrDoAuth $ \usr -> do 69 | lreq <- request 70 | (Just gid) <- queryParam "id" 71 | liftLIO . withHailsRockDB $ do 72 | ldoc <- liftLIO $ labeledRequestToHson lreq 73 | lrec <- fromLabeledDocument ldoc 74 | insertLabeledRecord (lrec :: DCLabeled Play) 75 | return $ redirectTo $ "/game/" ++ (S8.unpack gid) ++ "/status" 76 | 77 | -- Get status on wins 78 | Frank.get "/game/:id/status" $ withUserOrDoAuth $ \usr -> do 79 | lreq <- request 80 | (Just gid) <- queryParam "id" 81 | let _id = read . S8.unpack $ gid :: ObjectId 82 | mplay <- liftLIO . withHailsRockDB $ do 83 | findWhere $ select ["game" -: _id, "player" -: usr] "plays" 84 | case mplay of 85 | Nothing -> return notFound 86 | Just play -> do liftLIO $ ioTCB $ putStrLn $ "GET HERE" 87 | stats <- liftLIO $ getStats play 88 | liftLIO $ ioTCB $ putStrLn $ "stats = " ++ show stats 89 | return $ respondHtml $ showStats stats 90 | 91 | -- Enable login 92 | Frank.get "/login" $ withUserOrDoAuth $ 93 | const (return $ redirectTo "/") 94 | 95 | -------------------------------------------------------------------------------- /examples/hails-rock/HailsRock/MP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module HailsRock.MP ( HailsRockModule 8 | , withHailsRockDB 9 | , Game(..) 10 | , Play(..) 11 | , Move(..) 12 | , Outcome(..) 13 | , getStats 14 | ) where 15 | 16 | import Prelude hiding (lookup) 17 | 18 | import Data.Maybe (listToMaybe) 19 | import Data.Monoid (mempty) 20 | import Data.Typeable 21 | import qualified Data.ByteString.Char8 as S8 22 | import qualified Data.Text as T 23 | 24 | import Control.Monad 25 | 26 | import LIO 27 | import LIO.DCLabel 28 | 29 | import Hails.Data.Hson 30 | import Hails.Database 31 | import Hails.Database.Structured 32 | import Hails.PolicyModule 33 | import Hails.PolicyModule.DSL 34 | import Hails.Web 35 | 36 | -- | A game contains can be public or contain a single opponent 37 | data Game = Game { gameId :: Maybe ObjectId 38 | , creator :: UserName 39 | , opponent :: Maybe UserName } deriving (Show) 40 | 41 | data Move = Rock | Paper | Scissors deriving (Eq, Read, Show, Enum, Bounded) 42 | 43 | -- | A play is a move played by a user for a game 44 | data Play = Play { playId :: Maybe ObjectId 45 | , game :: ObjectId 46 | , player :: UserName 47 | , move :: Move } deriving (Show) 48 | 49 | data Outcome = Lose | Tie | Win deriving (Show, Eq, Ord) 50 | 51 | -- | @outcome our_move their_move@ 52 | outcome :: Move -> Move -> Outcome 53 | outcome Rock Scissors = Win 54 | outcome Paper Rock = Win 55 | outcome Scissors Paper = Win 56 | outcome us them | us == them = Tie 57 | outcome _ _ = Lose 58 | 59 | instance DCRecord Game where 60 | fromDocument doc = do 61 | let _id = lookupObjId "_id" doc 62 | p1 <- lookup "creator" doc 63 | -- Ignore empty-string opponents 64 | let p2 = do op <- lookup "opponent" doc 65 | let u = T.unwords . T.words $ op 66 | if T.null u 67 | then fail "Null opponent" 68 | else return u 69 | return Game { gameId = _id 70 | , creator = p1 71 | , opponent = p2 } 72 | 73 | toDocument game = 74 | let emptyOr f m = maybe [] (\i -> [f -: i]) m 75 | _id = emptyOr "_id" $ gameId game 76 | opp = emptyOr "opponent" $ opponent game 77 | in _id ++ [ "creator" -: creator game ] ++ opp 78 | 79 | recordCollection _ = "games" 80 | 81 | instance DCLabeledRecord HailsRockModule Game where 82 | endorseInstance _ = HailsRockModuleTCB mempty 83 | 84 | instance DCRecord Play where 85 | fromDocument doc = do 86 | let _id = lookupObjId "_id" doc 87 | gid <- lookupObjId "game" doc 88 | p <- lookup "player" doc 89 | mv <- lookupMove "move" doc 90 | return Play { playId = _id 91 | , game = gid 92 | , player = p 93 | , move = mv } 94 | 95 | toDocument play = 96 | let emptyOr f m = maybe [] (\i -> [f -: i]) m 97 | _id = emptyOr "_id" $ playId play 98 | in _id ++ [ "game" -: game play 99 | , "player" -: player play 100 | , "move" -: (show $ move play) ] 101 | 102 | recordCollection _ = "plays" 103 | 104 | instance DCLabeledRecord HailsRockModule Play where 105 | endorseInstance _ = HailsRockModuleTCB mempty 106 | 107 | -- 108 | -- 109 | -- 110 | 111 | 112 | data HailsRockModule = HailsRockModuleTCB DCPriv 113 | deriving Typeable 114 | 115 | instance PolicyModule HailsRockModule where 116 | initPolicyModule priv = do 117 | setPolicy priv $ do 118 | database $ do 119 | readers ==> unrestricted 120 | writers ==> unrestricted 121 | admins ==> this 122 | -- 123 | collection "games" $ do 124 | access $ do 125 | readers ==> unrestricted 126 | writers ==> unrestricted 127 | clearance $ do 128 | secrecy ==> this 129 | integrity ==> unrestricted 130 | document $ \doc -> do 131 | let (Just game) = fromDocument doc 132 | readers ==> unrestricted 133 | writers ==> this \/ (userToPrincipal $ creator game) 134 | -- 135 | collection "plays" $ do 136 | access $ do 137 | readers ==> unrestricted 138 | writers ==> unrestricted 139 | clearance $ do 140 | secrecy ==> this 141 | integrity ==> unrestricted 142 | document $ \doc -> do 143 | let (Just play) = fromDocument doc 144 | readers ==> this \/ (userToPrincipal $ player play) 145 | writers ==> this \/ (userToPrincipal $ player play) 146 | field "game" key 147 | field "player" key 148 | return $ HailsRockModuleTCB priv 149 | where this = privDesc priv 150 | userToPrincipal = principal . T.unpack 151 | 152 | withHailsRockDB :: DBAction a -> DC a 153 | withHailsRockDB act = withPolicyModule (\(_ :: HailsRockModule) -> act) 154 | 155 | -- 156 | -- Sensitive getStats function 157 | -- 158 | 159 | getStats :: Play -> DC [(UserName, Outcome)] 160 | getStats playA = withPolicyModule $ \(HailsRockModuleTCB priv) -> do 161 | ps <- findAllPlays $ game playA 162 | stats <- forM ps $ \lplay -> do 163 | playB <- liftLIO $ unlabelP priv lplay 164 | return $ (player playB, outcome (move playA) (move playB)) 165 | return $ filter ((/= player playA) . fst) stats 166 | 167 | 168 | 169 | 170 | -- 171 | -- Helpers 172 | -- 173 | 174 | findAllPlays :: ObjectId -> DBAction [DCLabeled Play] 175 | findAllPlays _id = do 176 | cursor <- find $ select ["game" -: _id] "plays" 177 | cursorToRecords cursor [] 178 | where cursorToRecords cur docs = do 179 | mldoc <- next cur 180 | case mldoc of 181 | Just ldoc -> do 182 | d <- fromLabeledDocument ldoc 183 | cursorToRecords cur $ d:docs 184 | _ -> return $ reverse docs 185 | 186 | -- | Generic lookup with possible type cast 187 | lookupTyped :: (HsonVal a, Read a, Monad m) => FieldName -> HsonDocument -> m a 188 | lookupTyped n d = case lookup n d of 189 | Just i -> return i 190 | _ -> case do { s <- lookup n d; maybeRead s } of 191 | Just i -> return i 192 | _ -> fail $ "lookupTyped: cannot extract id from " ++ show n 193 | 194 | 195 | -- | Get object id (may need to convert from string). 196 | lookupObjId :: Monad m => FieldName -> HsonDocument -> m ObjectId 197 | lookupObjId = lookupTyped 198 | 199 | -- | Get move (may need to convert from string). 200 | lookupMove :: Monad m => FieldName -> HsonDocument -> m Move 201 | lookupMove f d = do 202 | s <- lookupTyped f d 203 | maybe (fail "lookupMove failed to find move") return $ maybeRead s 204 | 205 | -- | Try to read a value 206 | maybeRead :: Read a => String -> Maybe a 207 | maybeRead = fmap fst . listToMaybe . reads 208 | -------------------------------------------------------------------------------- /examples/hails-rock/HailsRock/Views.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module HailsRock.Views where 4 | 5 | import Prelude hiding (div, span, head, id) 6 | 7 | import Data.Maybe (isJust, fromJust) 8 | 9 | import qualified Data.ByteString.Lazy.Char8 as L8 10 | import qualified Data.Text as T 11 | 12 | import Text.Blaze.Html5 hiding (Tag, map) 13 | import Text.Blaze.Html5.Attributes hiding ( label, form, span 14 | , title, style ) 15 | import qualified Text.Blaze.Html5.Attributes as A 16 | import Text.Blaze.Html.Renderer.Utf8 17 | 18 | import Control.Monad (forM_, when) 19 | 20 | import Hails.Web hiding (body) 21 | import Hails.HttpServer.Types 22 | 23 | import HailsRock.MP 24 | 25 | 26 | respondHtml :: Html -> Response 27 | respondHtml content = okHtml $ renderHtml $ docTypeHtml $ do 28 | head $ do 29 | title "HailsRock" 30 | meta ! charset "utf-8" 31 | link ! rel "stylesheet" 32 | ! type_ "text/css" ! href "/static/css/bootstrap.css" 33 | script ! src "/static/js/jquery-1.10.1.js" $ "" 34 | script ! src "/static/js/bootstrap.js" $ "" 35 | script ! src "/static/js/application.js" $ "" 36 | body $ do 37 | div ! class_ "container-fluid" $ content 38 | 39 | welcome :: Maybe UserName -> Html 40 | welcome Nothing = do 41 | h1 $ "Welcome to HailsRock!" 42 | a ! class_ "btn btn-large btn-info" 43 | ! href "/login" 44 | $ "Login to play" 45 | welcome (Just usr) = do 46 | h1 $ toHtml $ "Welcome to HailsRock, " ++ T.unpack usr ++ "!" 47 | a ! class_ "btn btn-large btn-primary" 48 | ! href "/game/new" 49 | $ "Create a new game" 50 | " " 51 | a ! class_ "btn btn-large" 52 | ! href "/game" 53 | $ "Join a game" 54 | 55 | newGame :: UserName -> Html 56 | newGame usr = do 57 | h1 $ "Create a new game" 58 | div $ do 59 | form ! action "/game/create" ! method "POST" ! id "newGame"$ do 60 | div $ do 61 | input ! type_ "hidden" ! name "creator" 62 | ! value (toValue usr) 63 | div $ do 64 | label ! for "opponent" $ "Opponent (optional):" 65 | input ! type_ "text" 66 | ! name "opponent" ! id "opponent" 67 | ! placeholder "rick-james" 68 | div ! class_ "btn-group" $ do 69 | input ! type_ "submit" ! class_ "btn" ! value "Create" 70 | 71 | listGames :: UserName -> [Game] -> Html 72 | listGames usr gs' = do 73 | -- Get all the games for which the current user is not the creator; 74 | let gs = filter ((/= usr) . creator) gs' 75 | -- 76 | h1 $ "Available games" 77 | div $ if null gs 78 | then p $ "Sorry, no games ... :-(" 79 | else table ! class_ "table table-hover table-condensed" $ do 80 | thead $ tr $ do 81 | th $ "#" 82 | th $ "Creator" 83 | th $ "Private" 84 | tbody $ do 85 | forM_ (zip [1..] gs) $ \(nr,game) -> do 86 | let tagUrl = "/game/" ++ show (fromJust $ gameId game) 87 | tr ! onclick (toValue $ "location.href=" ++ show tagUrl )$ do 88 | td $ toHtml (nr :: Int) 89 | td $ toHtml $ creator game 90 | td $ when (isJust $ opponent game) $ "1-vs-1" 91 | 92 | playGame :: UserName -> Game -> Bool -> Html 93 | playGame usr game True = do 94 | h1 $ "You already played!" 95 | playGame usr game False = do 96 | h1 $ "Make your move..." 97 | div $ do 98 | let gid = show . fromJust . gameId $ game 99 | form ! action (toValue $ "/game/"++gid++"/play") 100 | ! method "POST" ! id "newGame"$ do 101 | input ! type_ "hidden" ! name "game" 102 | ! value (toValue gid) 103 | input ! type_ "hidden" ! name "player" 104 | ! value (toValue usr) 105 | input ! name "move" 106 | ! type_ "submit" 107 | ! class_ "btn btn-large btn-info" 108 | ! value (toValue $ show Rock) 109 | " " 110 | input ! name "move" 111 | ! type_ "submit" 112 | ! class_ "btn btn-large btn-primary" 113 | ! value (toValue $ show Paper) 114 | " " 115 | input ! name "move" 116 | ! type_ "submit" 117 | ! class_ "btn btn-large btn-inverse" 118 | ! value (toValue $ show Scissors) 119 | 120 | showStats :: [(UserName, Outcome)] -> Html 121 | showStats stats = do 122 | h1 $ "Your move status" 123 | div $ if null stats 124 | then p $ "Sorry, nobody has played your move... :-(" 125 | else table ! class_ "table table-hover table-condensed" $ do 126 | thead $ tr $ do 127 | th $ "#" 128 | th $ "Player" 129 | th $ "Status" 130 | tbody $ do 131 | forM_ (zip [1..] stats) $ \(nr,(p,result)) -> do 132 | tr $ do 133 | td $ toHtml (nr :: Int) 134 | td $ toHtml $ T.unpack p 135 | td $ toHtml $ show result 136 | -------------------------------------------------------------------------------- /examples/hails-rock/database.conf: -------------------------------------------------------------------------------- 1 | ("main:HailsRock.MP.HailsRockModule","hails_rock_db") 2 | -------------------------------------------------------------------------------- /examples/hails-rock/static/css/bootstrap-responsive.min.css: -------------------------------------------------------------------------------- 1 | /*! 2 | * Bootstrap Responsive v2.3.2 3 | * 4 | * Copyright 2012 Twitter, Inc 5 | * Licensed under the Apache License v2.0 6 | * http://www.apache.org/licenses/LICENSE-2.0 7 | * 8 | * Designed and built with all the love in the world @twitter by @mdo and @fat. 9 | */.clearfix{*zoom:1}.clearfix:before,.clearfix:after{display:table;line-height:0;content:""}.clearfix:after{clear:both}.hide-text{font:0/0 a;color:transparent;text-shadow:none;background-color:transparent;border:0}.input-block-level{display:block;width:100%;min-height:30px;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}@-ms-viewport{width:device-width}.hidden{display:none;visibility:hidden}.visible-phone{display:none!important}.visible-tablet{display:none!important}.hidden-desktop{display:none!important}.visible-desktop{display:inherit!important}@media(min-width:768px) and (max-width:979px){.hidden-desktop{display:inherit!important}.visible-desktop{display:none!important}.visible-tablet{display:inherit!important}.hidden-tablet{display:none!important}}@media(max-width:767px){.hidden-desktop{display:inherit!important}.visible-desktop{display:none!important}.visible-phone{display:inherit!important}.hidden-phone{display:none!important}}.visible-print{display:none!important}@media print{.visible-print{display:inherit!important}.hidden-print{display:none!important}}@media(min-width:1200px){.row{margin-left:-30px;*zoom:1}.row:before,.row:after{display:table;line-height:0;content:""}.row:after{clear:both}[class*="span"]{float:left;min-height:1px;margin-left:30px}.container,.navbar-static-top .container,.navbar-fixed-top .container,.navbar-fixed-bottom .container{width:1170px}.span12{width:1170px}.span11{width:1070px}.span10{width:970px}.span9{width:870px}.span8{width:770px}.span7{width:670px}.span6{width:570px}.span5{width:470px}.span4{width:370px}.span3{width:270px}.span2{width:170px}.span1{width:70px}.offset12{margin-left:1230px}.offset11{margin-left:1130px}.offset10{margin-left:1030px}.offset9{margin-left:930px}.offset8{margin-left:830px}.offset7{margin-left:730px}.offset6{margin-left:630px}.offset5{margin-left:530px}.offset4{margin-left:430px}.offset3{margin-left:330px}.offset2{margin-left:230px}.offset1{margin-left:130px}.row-fluid{width:100%;*zoom:1}.row-fluid:before,.row-fluid:after{display:table;line-height:0;content:""}.row-fluid:after{clear:both}.row-fluid [class*="span"]{display:block;float:left;width:100%;min-height:30px;margin-left:2.564102564102564%;*margin-left:2.5109110747408616%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="span"]:first-child{margin-left:0}.row-fluid .controls-row [class*="span"]+[class*="span"]{margin-left:2.564102564102564%}.row-fluid .span12{width:100%;*width:99.94680851063829%}.row-fluid .span11{width:91.45299145299145%;*width:91.39979996362975%}.row-fluid .span10{width:82.90598290598291%;*width:82.8527914166212%}.row-fluid .span9{width:74.35897435897436%;*width:74.30578286961266%}.row-fluid .span8{width:65.81196581196582%;*width:65.75877432260411%}.row-fluid .span7{width:57.26495726495726%;*width:57.21176577559556%}.row-fluid .span6{width:48.717948717948715%;*width:48.664757228587014%}.row-fluid .span5{width:40.17094017094017%;*width:40.11774868157847%}.row-fluid .span4{width:31.623931623931625%;*width:31.570740134569924%}.row-fluid .span3{width:23.076923076923077%;*width:23.023731587561375%}.row-fluid .span2{width:14.52991452991453%;*width:14.476723040552828%}.row-fluid .span1{width:5.982905982905983%;*width:5.929714493544281%}.row-fluid .offset12{margin-left:105.12820512820512%;*margin-left:105.02182214948171%}.row-fluid .offset12:first-child{margin-left:102.56410256410257%;*margin-left:102.45771958537915%}.row-fluid .offset11{margin-left:96.58119658119658%;*margin-left:96.47481360247316%}.row-fluid .offset11:first-child{margin-left:94.01709401709402%;*margin-left:93.91071103837061%}.row-fluid .offset10{margin-left:88.03418803418803%;*margin-left:87.92780505546462%}.row-fluid .offset10:first-child{margin-left:85.47008547008548%;*margin-left:85.36370249136206%}.row-fluid .offset9{margin-left:79.48717948717949%;*margin-left:79.38079650845607%}.row-fluid .offset9:first-child{margin-left:76.92307692307693%;*margin-left:76.81669394435352%}.row-fluid .offset8{margin-left:70.94017094017094%;*margin-left:70.83378796144753%}.row-fluid .offset8:first-child{margin-left:68.37606837606839%;*margin-left:68.26968539734497%}.row-fluid .offset7{margin-left:62.393162393162385%;*margin-left:62.28677941443899%}.row-fluid .offset7:first-child{margin-left:59.82905982905982%;*margin-left:59.72267685033642%}.row-fluid .offset6{margin-left:53.84615384615384%;*margin-left:53.739770867430444%}.row-fluid .offset6:first-child{margin-left:51.28205128205128%;*margin-left:51.175668303327875%}.row-fluid .offset5{margin-left:45.299145299145295%;*margin-left:45.1927623204219%}.row-fluid .offset5:first-child{margin-left:42.73504273504273%;*margin-left:42.62865975631933%}.row-fluid .offset4{margin-left:36.75213675213675%;*margin-left:36.645753773413354%}.row-fluid .offset4:first-child{margin-left:34.18803418803419%;*margin-left:34.081651209310785%}.row-fluid .offset3{margin-left:28.205128205128204%;*margin-left:28.0987452264048%}.row-fluid .offset3:first-child{margin-left:25.641025641025642%;*margin-left:25.53464266230224%}.row-fluid .offset2{margin-left:19.65811965811966%;*margin-left:19.551736679396257%}.row-fluid .offset2:first-child{margin-left:17.094017094017094%;*margin-left:16.98763411529369%}.row-fluid .offset1{margin-left:11.11111111111111%;*margin-left:11.004728132387708%}.row-fluid .offset1:first-child{margin-left:8.547008547008547%;*margin-left:8.440625568285142%}input,textarea,.uneditable-input{margin-left:0}.controls-row [class*="span"]+[class*="span"]{margin-left:30px}input.span12,textarea.span12,.uneditable-input.span12{width:1156px}input.span11,textarea.span11,.uneditable-input.span11{width:1056px}input.span10,textarea.span10,.uneditable-input.span10{width:956px}input.span9,textarea.span9,.uneditable-input.span9{width:856px}input.span8,textarea.span8,.uneditable-input.span8{width:756px}input.span7,textarea.span7,.uneditable-input.span7{width:656px}input.span6,textarea.span6,.uneditable-input.span6{width:556px}input.span5,textarea.span5,.uneditable-input.span5{width:456px}input.span4,textarea.span4,.uneditable-input.span4{width:356px}input.span3,textarea.span3,.uneditable-input.span3{width:256px}input.span2,textarea.span2,.uneditable-input.span2{width:156px}input.span1,textarea.span1,.uneditable-input.span1{width:56px}.thumbnails{margin-left:-30px}.thumbnails>li{margin-left:30px}.row-fluid .thumbnails{margin-left:0}}@media(min-width:768px) and (max-width:979px){.row{margin-left:-20px;*zoom:1}.row:before,.row:after{display:table;line-height:0;content:""}.row:after{clear:both}[class*="span"]{float:left;min-height:1px;margin-left:20px}.container,.navbar-static-top .container,.navbar-fixed-top .container,.navbar-fixed-bottom .container{width:724px}.span12{width:724px}.span11{width:662px}.span10{width:600px}.span9{width:538px}.span8{width:476px}.span7{width:414px}.span6{width:352px}.span5{width:290px}.span4{width:228px}.span3{width:166px}.span2{width:104px}.span1{width:42px}.offset12{margin-left:764px}.offset11{margin-left:702px}.offset10{margin-left:640px}.offset9{margin-left:578px}.offset8{margin-left:516px}.offset7{margin-left:454px}.offset6{margin-left:392px}.offset5{margin-left:330px}.offset4{margin-left:268px}.offset3{margin-left:206px}.offset2{margin-left:144px}.offset1{margin-left:82px}.row-fluid{width:100%;*zoom:1}.row-fluid:before,.row-fluid:after{display:table;line-height:0;content:""}.row-fluid:after{clear:both}.row-fluid [class*="span"]{display:block;float:left;width:100%;min-height:30px;margin-left:2.7624309392265194%;*margin-left:2.709239449864817%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="span"]:first-child{margin-left:0}.row-fluid .controls-row [class*="span"]+[class*="span"]{margin-left:2.7624309392265194%}.row-fluid .span12{width:100%;*width:99.94680851063829%}.row-fluid .span11{width:91.43646408839778%;*width:91.38327259903608%}.row-fluid .span10{width:82.87292817679558%;*width:82.81973668743387%}.row-fluid .span9{width:74.30939226519337%;*width:74.25620077583166%}.row-fluid .span8{width:65.74585635359117%;*width:65.69266486422946%}.row-fluid .span7{width:57.18232044198895%;*width:57.12912895262725%}.row-fluid .span6{width:48.61878453038674%;*width:48.56559304102504%}.row-fluid .span5{width:40.05524861878453%;*width:40.00205712942283%}.row-fluid .span4{width:31.491712707182323%;*width:31.43852121782062%}.row-fluid .span3{width:22.92817679558011%;*width:22.87498530621841%}.row-fluid .span2{width:14.3646408839779%;*width:14.311449394616199%}.row-fluid .span1{width:5.801104972375691%;*width:5.747913483013988%}.row-fluid .offset12{margin-left:105.52486187845304%;*margin-left:105.41847889972962%}.row-fluid .offset12:first-child{margin-left:102.76243093922652%;*margin-left:102.6560479605031%}.row-fluid .offset11{margin-left:96.96132596685082%;*margin-left:96.8549429881274%}.row-fluid .offset11:first-child{margin-left:94.1988950276243%;*margin-left:94.09251204890089%}.row-fluid .offset10{margin-left:88.39779005524862%;*margin-left:88.2914070765252%}.row-fluid .offset10:first-child{margin-left:85.6353591160221%;*margin-left:85.52897613729868%}.row-fluid .offset9{margin-left:79.8342541436464%;*margin-left:79.72787116492299%}.row-fluid .offset9:first-child{margin-left:77.07182320441989%;*margin-left:76.96544022569647%}.row-fluid .offset8{margin-left:71.2707182320442%;*margin-left:71.16433525332079%}.row-fluid .offset8:first-child{margin-left:68.50828729281768%;*margin-left:68.40190431409427%}.row-fluid .offset7{margin-left:62.70718232044199%;*margin-left:62.600799341718584%}.row-fluid .offset7:first-child{margin-left:59.94475138121547%;*margin-left:59.838368402492065%}.row-fluid .offset6{margin-left:54.14364640883978%;*margin-left:54.037263430116376%}.row-fluid .offset6:first-child{margin-left:51.38121546961326%;*margin-left:51.27483249088986%}.row-fluid .offset5{margin-left:45.58011049723757%;*margin-left:45.47372751851417%}.row-fluid .offset5:first-child{margin-left:42.81767955801105%;*margin-left:42.71129657928765%}.row-fluid .offset4{margin-left:37.01657458563536%;*margin-left:36.91019160691196%}.row-fluid .offset4:first-child{margin-left:34.25414364640884%;*margin-left:34.14776066768544%}.row-fluid .offset3{margin-left:28.45303867403315%;*margin-left:28.346655695309746%}.row-fluid .offset3:first-child{margin-left:25.69060773480663%;*margin-left:25.584224756083227%}.row-fluid .offset2{margin-left:19.88950276243094%;*margin-left:19.783119783707537%}.row-fluid .offset2:first-child{margin-left:17.12707182320442%;*margin-left:17.02068884448102%}.row-fluid .offset1{margin-left:11.32596685082873%;*margin-left:11.219583872105325%}.row-fluid .offset1:first-child{margin-left:8.56353591160221%;*margin-left:8.457152932878806%}input,textarea,.uneditable-input{margin-left:0}.controls-row [class*="span"]+[class*="span"]{margin-left:20px}input.span12,textarea.span12,.uneditable-input.span12{width:710px}input.span11,textarea.span11,.uneditable-input.span11{width:648px}input.span10,textarea.span10,.uneditable-input.span10{width:586px}input.span9,textarea.span9,.uneditable-input.span9{width:524px}input.span8,textarea.span8,.uneditable-input.span8{width:462px}input.span7,textarea.span7,.uneditable-input.span7{width:400px}input.span6,textarea.span6,.uneditable-input.span6{width:338px}input.span5,textarea.span5,.uneditable-input.span5{width:276px}input.span4,textarea.span4,.uneditable-input.span4{width:214px}input.span3,textarea.span3,.uneditable-input.span3{width:152px}input.span2,textarea.span2,.uneditable-input.span2{width:90px}input.span1,textarea.span1,.uneditable-input.span1{width:28px}}@media(max-width:767px){body{padding-right:20px;padding-left:20px}.navbar-fixed-top,.navbar-fixed-bottom,.navbar-static-top{margin-right:-20px;margin-left:-20px}.container-fluid{padding:0}.dl-horizontal dt{float:none;width:auto;clear:none;text-align:left}.dl-horizontal dd{margin-left:0}.container{width:auto}.row-fluid{width:100%}.row,.thumbnails{margin-left:0}.thumbnails>li{float:none;margin-left:0}[class*="span"],.uneditable-input[class*="span"],.row-fluid [class*="span"]{display:block;float:none;width:100%;margin-left:0;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.span12,.row-fluid .span12{width:100%;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.row-fluid [class*="offset"]:first-child{margin-left:0}.input-large,.input-xlarge,.input-xxlarge,input[class*="span"],select[class*="span"],textarea[class*="span"],.uneditable-input{display:block;width:100%;min-height:30px;-webkit-box-sizing:border-box;-moz-box-sizing:border-box;box-sizing:border-box}.input-prepend input,.input-append input,.input-prepend input[class*="span"],.input-append input[class*="span"]{display:inline-block;width:auto}.controls-row [class*="span"]+[class*="span"]{margin-left:0}.modal{position:fixed;top:20px;right:20px;left:20px;width:auto;margin:0}.modal.fade{top:-100px}.modal.fade.in{top:20px}}@media(max-width:480px){.nav-collapse{-webkit-transform:translate3d(0,0,0)}.page-header h1 small{display:block;line-height:20px}input[type="checkbox"],input[type="radio"]{border:1px solid #ccc}.form-horizontal .control-label{float:none;width:auto;padding-top:0;text-align:left}.form-horizontal .controls{margin-left:0}.form-horizontal .control-list{padding-top:0}.form-horizontal .form-actions{padding-right:10px;padding-left:10px}.media .pull-left,.media .pull-right{display:block;float:none;margin-bottom:10px}.media-object{margin-right:0;margin-left:0}.modal{top:10px;right:10px;left:10px}.modal-header .close{padding:10px;margin:-10px}.carousel-caption{position:static}}@media(max-width:979px){body{padding-top:0}.navbar-fixed-top,.navbar-fixed-bottom{position:static}.navbar-fixed-top{margin-bottom:20px}.navbar-fixed-bottom{margin-top:20px}.navbar-fixed-top .navbar-inner,.navbar-fixed-bottom .navbar-inner{padding:5px}.navbar .container{width:auto;padding:0}.navbar .brand{padding-right:10px;padding-left:10px;margin:0 0 0 -5px}.nav-collapse{clear:both}.nav-collapse .nav{float:none;margin:0 0 10px}.nav-collapse .nav>li{float:none}.nav-collapse .nav>li>a{margin-bottom:2px}.nav-collapse .nav>.divider-vertical{display:none}.nav-collapse .nav .nav-header{color:#777;text-shadow:none}.nav-collapse .nav>li>a,.nav-collapse .dropdown-menu a{padding:9px 15px;font-weight:bold;color:#777;-webkit-border-radius:3px;-moz-border-radius:3px;border-radius:3px}.nav-collapse .btn{padding:4px 10px 4px;font-weight:normal;-webkit-border-radius:4px;-moz-border-radius:4px;border-radius:4px}.nav-collapse .dropdown-menu li+li a{margin-bottom:2px}.nav-collapse .nav>li>a:hover,.nav-collapse .nav>li>a:focus,.nav-collapse .dropdown-menu a:hover,.nav-collapse .dropdown-menu a:focus{background-color:#f2f2f2}.navbar-inverse .nav-collapse .nav>li>a,.navbar-inverse .nav-collapse .dropdown-menu a{color:#999}.navbar-inverse .nav-collapse .nav>li>a:hover,.navbar-inverse .nav-collapse .nav>li>a:focus,.navbar-inverse .nav-collapse .dropdown-menu a:hover,.navbar-inverse .nav-collapse .dropdown-menu a:focus{background-color:#111}.nav-collapse.in .btn-group{padding:0;margin-top:5px}.nav-collapse .dropdown-menu{position:static;top:auto;left:auto;display:none;float:none;max-width:none;padding:0;margin:0 15px;background-color:transparent;border:0;-webkit-border-radius:0;-moz-border-radius:0;border-radius:0;-webkit-box-shadow:none;-moz-box-shadow:none;box-shadow:none}.nav-collapse .open>.dropdown-menu{display:block}.nav-collapse .dropdown-menu:before,.nav-collapse .dropdown-menu:after{display:none}.nav-collapse .dropdown-menu .divider{display:none}.nav-collapse .nav>li>.dropdown-menu:before,.nav-collapse .nav>li>.dropdown-menu:after{display:none}.nav-collapse .navbar-form,.nav-collapse .navbar-search{float:none;padding:10px 15px;margin:10px 0;border-top:1px solid #f2f2f2;border-bottom:1px solid #f2f2f2;-webkit-box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.1);-moz-box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.1);box-shadow:inset 0 1px 0 rgba(255,255,255,0.1),0 1px 0 rgba(255,255,255,0.1)}.navbar-inverse .nav-collapse .navbar-form,.navbar-inverse .nav-collapse .navbar-search{border-top-color:#111;border-bottom-color:#111}.navbar .nav-collapse .nav.pull-right{float:none;margin-left:0}.nav-collapse,.nav-collapse.collapse{height:0;overflow:hidden}.navbar .btn-navbar{display:block}.navbar-static .navbar-inner{padding-right:10px;padding-left:10px}}@media(min-width:980px){.nav-collapse.collapse{height:auto!important;overflow:visible!important}} 10 | -------------------------------------------------------------------------------- /examples/hails-rock/static/img/glyphicons-halflings-white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/hails-rock/static/img/glyphicons-halflings-white.png -------------------------------------------------------------------------------- /examples/hails-rock/static/img/glyphicons-halflings.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scslab/hails/4d4dfe0cdfb7c8941a55ce882cba20d82c6d9cfd/examples/hails-rock/static/img/glyphicons-halflings.png -------------------------------------------------------------------------------- /examples/hails-rock/static/js/application.js: -------------------------------------------------------------------------------- 1 | $(document).ready(function() { 2 | $("#newGame").submit(function() { 3 | if ($("#opponent").val() == "") { 4 | $("#opponent").attr("disabled",true); 5 | } 6 | }); 7 | }); 8 | -------------------------------------------------------------------------------- /examples/httpClientExample.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | import LIO 3 | import LIO.TCB (ioTCB) 4 | import LIO.DCLabel 5 | import LIO.Privs.TCB 6 | 7 | import Hails.HttpClient 8 | 9 | dcPutStrLn :: String -> DC () 10 | dcPutStrLn s = ioTCB $ putStrLn s 11 | 12 | alicePriv :: DCPriv 13 | alicePriv = mintTCB (dcPrivDesc "alice") 14 | 15 | evalDC' :: DC () -> IO () 16 | evalDC' io = do 17 | (_, s) <- runDC io 18 | putStrLn $ show $ lioLabel s 19 | 20 | main :: IO () 21 | main = evalDC' $ do 22 | case exNr of 23 | 1 {- OK -} -> exMap False "maps.googleapis.com" mapBase 24 | 2 {- OK SSL -} -> exMap True "maps.googleapis.com" mapBaseS 25 | 3 {- FAIL -} -> exMap False "maps.yahoo.com" mapBase 26 | 4 {- FAIL -} -> exMap False "maps.googleapis.com" "http://maps.google.com" 27 | 5 {- FAIL -} -> exMap True "maps.googleapis.com" mapBase 28 | _ -> return () 29 | where exNr = 1 :: Int 30 | mapBase = "http://maps.googleapis.com/maps/api/geocode/json?sensor=false" 31 | mapBaseS = "https://maps.googleapis.com/maps/api/geocode/json?sensor=false" 32 | 33 | exMap :: Bool -> String -> String -> DC () 34 | exMap sec domain mapBase = do 35 | let aliceLocL = dcLabel ("alice" /\ (scheme ++ domain ++ p)) dcTrue 36 | myLoc <- labelP alicePriv aliceLocL "3101 24th Street, San Francisco, CA" 37 | aliceLoc <- unlabelP alicePriv myLoc 38 | resp <- simpleGetHttp $ mapBase ++ "&address=" ++ aliceLoc 39 | dcPutStrLn (show resp) 40 | where scheme = (if sec then "https" else "http") ++ "://" 41 | p = if sec then ":443" else ":80" 42 | -------------------------------------------------------------------------------- /examples/simpleDBExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, 2 | ScopedTypeVariables, 3 | OverloadedStrings #-} 4 | 5 | module Main (main) where 6 | 7 | import Data.Typeable 8 | import Data.Text () 9 | 10 | import Control.Monad 11 | 12 | import LIO 13 | import LIO.DCLabel 14 | import Hails.Data.Hson 15 | import Hails.Database 16 | import Hails.PolicyModule 17 | import Hails.PolicyModule.DSL 18 | 19 | import LIO.TCB (ioTCB) 20 | import LIO.Privs.TCB (mintTCB) 21 | import LIO.DCLabel.Privs.TCB (allPrivTCB) 22 | import System.Posix.Env (setEnv) 23 | 24 | data UsersPolicyModule = UsersPolicyModuleTCB DCPriv 25 | deriving Typeable 26 | 27 | instance PolicyModule UsersPolicyModule where 28 | initPolicyModule priv = do 29 | setPolicy priv $ do 30 | database $ do 31 | readers ==> anybody 32 | writers ==> anybody 33 | admins ==> this 34 | collection "users" $ do 35 | access $ do 36 | readers ==> anybody 37 | writers ==> anybody 38 | clearance $ do 39 | secrecy ==> this 40 | integrity ==> anybody 41 | document $ \_ -> do 42 | readers ==> anybody 43 | writers ==> anybody 44 | field "name" $ searchable 45 | field "password" $ labeled $ \doc -> do 46 | let user = "name" `at` doc :: String 47 | readers ==> this \/ user 48 | writers ==> this \/ user 49 | return $ UsersPolicyModuleTCB priv 50 | where this = privDesc priv 51 | 52 | withUsersPolicyModule :: DBAction a -> DC a 53 | withUsersPolicyModule act = withPolicyModule (\(_ :: UsersPolicyModule) -> act) 54 | 55 | 56 | -- | Create databse config file 57 | mkDBConfFile :: IO () 58 | mkDBConfFile = do 59 | writeFile dbConfFile (unlines [show pm]) 60 | setEnv "DATABASE_CONFIG_FILE" dbConfFile False 61 | where pm :: (String, String) 62 | pm = (mkName (UsersPolicyModuleTCB undefined), "users_db") 63 | dbConfFile = "/tmp/hails_example_database.conf" 64 | mkName x = 65 | let tp = typeRepTyCon $ typeOf x 66 | in tyConPackage tp ++ ":" ++ tyConModule tp ++ "." ++ tyConName tp 67 | 68 | main :: IO () 69 | main = do 70 | mkDBConfFile 71 | withUser "alice" app1 72 | withUser "bob" (app2 False) 73 | withUser "bob" (app2 True) 74 | withUser "alice" (app2 True) 75 | where withUser :: String -> (String -> DCPriv -> DC ()) -> IO () 76 | withUser u act = putStrLn . show =<< (paranoidDC $ do 77 | let prin = toComponent u 78 | setClearanceP allPrivTCB (dcLabel prin dcTrue) 79 | act u $ mintTCB prin) 80 | 81 | app1 :: String -> DCPriv -> DC () 82 | app1 usr priv = do 83 | let p = toBsonValue ("w00tw00t" :: String) 84 | withUsersPolicyModule $ do 85 | let doc :: HsonDocument 86 | doc = [ "name" -: usr, "password" -: needPolicy p] 87 | insertP_ priv "users" doc 88 | 89 | app2 :: Bool -> String -> DCPriv -> DC () 90 | app2 readPass _ priv = do 91 | ldocs <- withUsersPolicyModule $ do 92 | cur <-findP priv $ select [] "users" 93 | getAll [] cur 94 | -- 95 | forM_ ldocs $ \ldoc -> do 96 | doc <- unlabelP priv ldoc 97 | putStrLn' $ "name = " ++ ("name" `at` doc) 98 | when readPass $ do 99 | lpass <- getPolicyLabeled ("password" `at` doc) 100 | pass <- unlabelP priv lpass 101 | putStrLn' $ "password = " ++ show pass 102 | where getAll acc cur = do 103 | mldoc <- nextP priv cur 104 | case mldoc of 105 | Nothing -> return acc 106 | Just ldoc -> getAll (ldoc:acc) cur 107 | 108 | putStrLn' :: String -> DC () 109 | putStrLn' m = ioTCB $ putStrLn m 110 | -------------------------------------------------------------------------------- /hails.cabal: -------------------------------------------------------------------------------- 1 | Name: hails 2 | Version: 0.11.2.1 3 | build-type: Simple 4 | License: MIT 5 | License-File: LICENSE 6 | Author: Hails team 7 | Maintainer: Hails team 8 | Synopsis: Multi-app web platform framework 9 | Category: Web 10 | Cabal-Version: >= 1.8 11 | 12 | Description: 13 | The rise of web platforms and their associated /apps/ represents a 14 | new way of developing and deploying software. Sites such as 15 | Facebook and Yammer are no longer written by a single entity, but 16 | rather are freely extended by third-party developers offering 17 | competing features to users. 18 | 19 | . 20 | 21 | Allowing an app to access more user data allows developers to build 22 | more compelling products. It also opens the door to accidental or 23 | malicious breaches of user privacy. In the case of a website like 24 | Facebook, exposing access to a user's private messages would allow 25 | an external developer to build a search feature. Exciting! But, 26 | another developer can take advantage of this feature to build an app 27 | that mines private messages for credit card numbers, ad keywords, or 28 | other sensitive data. 29 | 30 | . 31 | 32 | Frameworks such as Ruby on Rails, Django, Yesod, etc. are geared 33 | towards building monolithic web sites. And, they are great for 34 | this! However, they are not designed for websites that integrate 35 | third-party code, and thus lack a good mechanism for building such 36 | multi-app platforms without sacrificing a user's security or an 37 | app's functionality. 38 | 39 | . 40 | 41 | Hails is explicitly designed for building web /platforms/, where it 42 | is expected that a site will comprise many mutually-distrustful 43 | components written by a variety of entities. We built Hails around 44 | two core design principles. 45 | 46 | . 47 | 48 | * Separation of policy: 49 | Data access policies should be concisely specified alongside data 50 | structures and schemas, rather than strewn throughout the 51 | codebase in a series of conditionals. Code that implements this 52 | is called a /policy module/ in Hails (see "Hails.PolicyModule"). 53 | 54 | . 55 | 56 | 57 | * Mandatory access control (MAC): 58 | Data access policies should be mandatory even once code has 59 | obtained access to data. MAC lets platform components modules 60 | productively interact by sharing data, despite mutual distrust. 61 | Haskell lets us implement MAC at a fine grained level using the 62 | information flow control library "LIO". 63 | 64 | . 65 | 66 | A Hails platform hosts two types of code: /apps/ and /policy 67 | modules/. Apps encompass what would traditionally be considered 68 | controller and view logic. Policy modules are libraries that 69 | implement both the model and the data security policy. They are 70 | invoked directly by apps or other policy modules, but run with 71 | different privileges from the invoking code. Both apps and policy 72 | modules can be implemented by untrusted third parties, with the user 73 | only needing to trust the policy module governing the data in 74 | question. Separating of policy code from app code allows users to 75 | inspect and more easily unserstand the overall security provided by 76 | the system, while MAC guarantees that these policies are enforced 77 | in an end-to-end fashion. 78 | 79 | Extra-source-files: 80 | examples/simpleDBExample.hs 81 | examples/SimpleApp.hs 82 | examples/httpClientExample.hs 83 | 84 | Source-repository head 85 | Type: git 86 | Location: git://github.com/scslab/hails.git 87 | 88 | 89 | Library 90 | Build-Depends: 91 | base < 6 92 | ,transformers 93 | ,mtl 94 | ,containers 95 | ,bytestring 96 | ,text 97 | ,parsec 98 | ,binary 99 | ,time 100 | ,lio >= 0.11 101 | ,base64-bytestring 102 | ,bson 103 | ,mongoDB 104 | ,network 105 | ,http-conduit >= 2.1.0 106 | ,conduit 107 | ,conduit-extra 108 | ,resourcet 109 | ,exceptions 110 | ,wai >= 2.1 && < 3.0 111 | ,wai-app-static 112 | ,wai-extra 113 | ,http-types 114 | ,authenticate 115 | ,cookie 116 | ,blaze-builder 117 | ,failure 118 | ,SHA 119 | 120 | GHC-options: -Wall -fno-warn-orphans 121 | 122 | Exposed-modules: 123 | Hails.Data.Hson 124 | Hails.Data.Hson.TCB 125 | Hails.Database 126 | Hails.Database.Core 127 | Hails.Database.TCB 128 | Hails.Database.Query 129 | Hails.Database.Query.TCB 130 | Hails.Database.Structured 131 | Hails.HttpServer 132 | Hails.HttpServer.Auth 133 | Hails.HttpServer.Types 134 | Hails.PolicyModule 135 | Hails.PolicyModule.DSL 136 | Hails.PolicyModule.Groups 137 | Hails.PolicyModule.TCB 138 | Hails.HttpClient 139 | Hails.Version 140 | Hails.Web 141 | Hails.Web.User 142 | Hails.Web.Controller 143 | Hails.Web.Frank 144 | Hails.Web.REST 145 | Hails.Web.Responses 146 | Hails.Web.Router 147 | Other-modules: 148 | Paths_hails 149 | 150 | Executable hails 151 | Main-is: hails.hs 152 | ghc-options: -package ghc -Wall -fno-warn-orphans 153 | Build-Depends: 154 | base < 6 155 | ,transformers 156 | ,mtl 157 | ,containers 158 | ,bytestring 159 | ,text 160 | ,parsec 161 | ,binary 162 | ,time 163 | ,lio >= 0.11 164 | ,base64-bytestring 165 | ,bson 166 | ,mongoDB 167 | ,network 168 | ,http-conduit >= 2.1.0 169 | ,conduit 170 | ,conduit-extra 171 | ,resourcet 172 | ,exceptions 173 | ,wai >= 2.1 && < 3.0 174 | ,wai-extra 175 | ,wai-app-static 176 | ,warp 177 | ,http-types 178 | ,authenticate 179 | ,cookie 180 | ,blaze-builder 181 | ,directory 182 | ,filepath 183 | ,unix 184 | ,ghc-paths 185 | ,SHA 186 | ,hint 187 | ,hails 188 | 189 | test-suite tests 190 | type: exitcode-stdio-1.0 191 | hs-source-dirs: tests 192 | main-is: Tests.hs 193 | 194 | ghc-options: -threaded -rtsopts -Wall -fno-warn-orphans 195 | 196 | build-depends: 197 | hails 198 | ,base 199 | ,containers 200 | ,unix 201 | ,time 202 | ,text 203 | ,QuickCheck 204 | ,HUnit 205 | ,quickcheck-instances 206 | ,test-framework 207 | ,test-framework-quickcheck2 208 | ,test-framework-hunit 209 | ,lio 210 | ,quickcheck-lio-instances 211 | ,bson 212 | ,mongoDB 213 | ,wai 214 | ,wai-test 215 | ,http-types 216 | -------------------------------------------------------------------------------- /tests/AuthTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module AuthTests (tests) where 3 | 4 | import Test.Framework 5 | import Test.Framework.Providers.HUnit 6 | import Hails.HttpServer.Auth 7 | import Network.HTTP.Types 8 | import Network.Wai 9 | import Network.Wai.Test 10 | 11 | tests :: [Test] 12 | tests = [authTest] 13 | 14 | authTest :: Test 15 | authTest = testGroup "Auth" 16 | [ testCase "Require Login on X-Hails-Login header" $ runSession (do 17 | resp <- request getTop 18 | assertHeader "TestHeader" "MyHeaderVal" resp) $ 19 | requireLoginMiddleware (return $ responseLBS status301 [("TestHeader", "MyHeaderVal")] "") $ 20 | const . return $ responseLBS status401 [("x-hails-login", "yes")] "" 21 | , testCase "No login if not X-Hails-Login header" $ runSession (do 22 | resp <- request undefined 23 | assertNoHeader "TestHeader" resp) $ 24 | requireLoginMiddleware (return $ responseLBS status301 [("TestHeader", "ShouldNotBeThere")] "") $ 25 | const . return $ responseLBS status200 [] "" 26 | ] 27 | 28 | -- | Simple get request 29 | getTop :: Request 30 | getTop = Request { requestMethod = methodGet 31 | , httpVersion = http11 32 | , rawPathInfo = "" 33 | , rawQueryString = "" 34 | , serverName = "locahost" 35 | , serverPort = 8080 36 | , requestHeaders = [] 37 | , isSecure = False 38 | , remoteHost = undefined 39 | , pathInfo = [] 40 | , queryString = [] 41 | , requestBody = undefined 42 | , requestBodyLength = undefined 43 | , vault = undefined } 44 | 45 | -------------------------------------------------------------------------------- /tests/Hails/Data/Hson/Instances.hs: -------------------------------------------------------------------------------- 1 | 2 | module Hails.Data.Hson.Instances (clean, sortDoc) where 3 | 4 | import Data.List (sortBy, nubBy) 5 | import qualified Data.Text as T 6 | import Control.Applicative ((<$>), (<*>)) 7 | 8 | import Test.QuickCheck 9 | import Test.QuickCheck.Instances () 10 | 11 | import LIO.Instances () 12 | import Hails.Data.Hson 13 | import Hails.Data.Hson.TCB 14 | 15 | instance Arbitrary ObjectId where 16 | arbitrary = Oid <$> arbitrary <*> arbitrary 17 | 18 | instance Arbitrary Binary where 19 | arbitrary = Binary <$> arbitrary 20 | 21 | instance Arbitrary BsonValue where 22 | arbitrary = oneof [ BsonFloat <$> arbitrary 23 | , BsonString <$> arbitrary 24 | , BsonDoc <$> doc 25 | , BsonArray <$> arr 26 | , BsonBlob <$> arbitrary 27 | , BsonObjId <$> arbitrary 28 | , BsonBool <$> arbitrary 29 | -- TODO: comment this out when serialization bug in bson package is fixed. 30 | -- , BsonUTC <$> utc 31 | , return BsonNull 32 | , BsonInt32 <$> arbitrary 33 | , BsonInt64 <$> arbitrary 34 | ] 35 | where arr = sized $ \len -> take (min 3 len) <$> 36 | (arbitrary :: Gen [BsonValue]) 37 | doc = sized $ \len -> take (min 3 len) <$> 38 | (arbitrary :: Gen [BsonField]) 39 | -- utc = (\u -> u { utctDayTime = 0 }) <$> arbitrary 40 | 41 | instance Arbitrary BsonField where 42 | arbitrary = BsonField <$> n <*> arbitrary 43 | where n = oneof $ map (\x -> return . T.singleton $ x) ['A'..'Z'] 44 | 45 | instance Arbitrary PolicyLabeled where 46 | arbitrary = oneof [ NeedPolicyTCB <$> arbitrary 47 | , HasPolicyTCB <$> arbitrary ] 48 | 49 | 50 | instance Arbitrary HsonValue where 51 | arbitrary = oneof [ HsonValue <$> arbitrary 52 | , HsonLabeled <$> arbitrary ] 53 | 54 | instance Arbitrary HsonField where 55 | arbitrary = HsonField <$> n <*> arbitrary 56 | where n = oneof $ map (\x -> return . T.singleton $ x) ['A'..'Z'] 57 | 58 | -- | Remove documents with same field name 59 | clean :: (IsField f) => [f] -> [f] 60 | clean = nubBy (\f1 f2 -> fieldName f1 == fieldName f2) 61 | 62 | -- | Sort documents 63 | sortDoc :: (IsField f) => [f] -> [f] 64 | sortDoc = sortBy (\f1 f2 -> compare (fieldName f1) (fieldName f2)) 65 | -------------------------------------------------------------------------------- /tests/HsonTests.hs: -------------------------------------------------------------------------------- 1 | 2 | module HsonTests (tests) where 3 | 4 | import Data.List (sortBy, nubBy) 5 | import Data.Int (Int32, Int64) 6 | import Data.Time.Clock (UTCTime(..)) 7 | import qualified Data.Text as T 8 | 9 | import Data.Text (Text) 10 | import Test.Framework (Test, testGroup) 11 | import Test.Framework.Providers.QuickCheck2 (testProperty) 12 | 13 | import LIO.TCB 14 | import Hails.Data.Hson 15 | import Hails.Data.Hson.TCB 16 | import Hails.Data.Hson.Instances () 17 | 18 | tests :: [Test] 19 | tests = [ toFromHsonValue 20 | , testDocOps 21 | , testMarshall 22 | ] 23 | 24 | 25 | -- 26 | -- Test HsonVal class 27 | -- 28 | 29 | testHsonVal :: (HsonVal a, Eq a) => a -> Bool 30 | testHsonVal a = case fromHsonValue . toHsonValue $ a of 31 | Nothing -> False 32 | Just a' -> a == a' 33 | 34 | toFromHsonValue :: Test 35 | toFromHsonValue = testGroup "To/from HsonValue" 36 | [ testProperty "Bool" (testHsonVal :: Bool -> Bool) 37 | , testProperty "Double" (testHsonVal :: Double -> Bool) 38 | , testProperty "Float" (testHsonVal :: Float -> Bool) 39 | , testProperty "Int" (testHsonVal :: Int -> Bool) 40 | , testProperty "Int32" (testHsonVal :: Int32 -> Bool) 41 | , testProperty "Int64" (testHsonVal :: Int64 -> Bool) 42 | , testProperty "Integer" (testHsonVal :: Integer -> Bool) 43 | , testProperty "String" (testHsonVal :: String -> Bool) 44 | , testProperty "UTCTime" (testHsonVal :: UTCTime -> Bool) 45 | , testProperty "ObjectId" (testHsonVal :: ObjectId -> Bool) 46 | , testProperty "Binary" (testHsonVal :: Binary -> Bool) 47 | , testProperty "Text" (testHsonVal :: Text -> Bool) 48 | , testProperty "BsonDocument" (testHsonVal :: BsonDocument -> Bool) 49 | , testProperty "BsonValue" (testHsonVal :: BsonValue -> Bool) 50 | , testProperty "[BsonValue]" (testHsonVal :: [BsonValue] -> Bool) 51 | , testProperty "PolicyLabeled" (testHsonVal :: PolicyLabeled -> Bool) 52 | ] 53 | 54 | 55 | -- 56 | -- Test include, exclude and merge 57 | -- 58 | 59 | testDocOps :: Test 60 | testDocOps = testGroup "Document operations" 61 | [ testProperty "Include Bson" 62 | (testInclude :: BsonDocument -> BsonDocument -> Bool) 63 | , testProperty "Include Hson" 64 | (testInclude :: HsonDocument -> HsonDocument -> Bool) 65 | , testProperty "Exclude Bson" 66 | (testExclude :: BsonDocument -> BsonDocument -> Bool) 67 | , testProperty "Exclude Hson" 68 | (testExclude :: HsonDocument -> HsonDocument -> Bool) 69 | , testProperty "Merge Bson" 70 | (testMerge :: BsonDocument -> BsonDocument -> Bool) 71 | , testProperty "Merge Hson" 72 | (testMerge :: HsonDocument -> HsonDocument -> Bool) 73 | , testProperty "Merge idempotent Bson" 74 | (propMergeIdempotent :: BsonDocument -> BsonDocument -> Bool) 75 | , testProperty "Merge idempotent Hson" 76 | (propMergeIdempotent :: HsonDocument -> HsonDocument -> Bool) 77 | ] 78 | 79 | 80 | -- | Test include 81 | testInclude :: (IsField f, Eq f) => [f] -> [f] -> Bool 82 | testInclude d1 d2 = 83 | let doc1 = sortDoc . clean $ d1 84 | fs1 = map fieldName doc1 85 | doc2 = sortDoc . filter (\f -> fieldName f `notElem` fs1) . clean $ d2 86 | fs2 = map fieldName doc2 87 | doc = doc1 ++ doc2 88 | in sortDoc (include fs1 doc) == doc1 89 | && sortDoc (include fs2 doc) == doc2 90 | 91 | -- | Remove documents with same field name 92 | clean :: (IsField f) => [f] -> [f] 93 | clean = nubBy (\f1 f2 -> fieldName f1 == fieldName f2) 94 | 95 | -- | Sort documents 96 | sortDoc :: (IsField f) => [f] -> [f] 97 | sortDoc = sortBy (\f1 f2 -> compare (fieldName f1) (fieldName f2)) 98 | 99 | 100 | -- | Test exclude 101 | testExclude :: (IsField f, Eq f) => [f] -> [f] -> Bool 102 | testExclude d1 d2 = 103 | let doc1 = sortDoc . clean $ d1 104 | fs1 = map fieldName doc1 105 | doc2 = sortDoc . filter (\f -> fieldName f `notElem` fs1) . clean $ d2 106 | fs2 = map fieldName doc2 107 | doc = doc1 ++ doc2 108 | in sortDoc (exclude fs1 doc) == doc2 109 | && sortDoc (exclude fs2 doc) == doc1 110 | 111 | -- | Test merge 112 | testMerge :: (Show f, IsField f, Eq f) => [f] -> [f] -> Bool 113 | testMerge d1 d2 = 114 | let doc1 = sortDoc . clean $ d1 115 | fs1 = map fieldName doc1 116 | doc2 = sortDoc . clean $ d2 117 | doc2_nub = sortDoc . filter (\f -> fieldName f `notElem` fs1) $ doc2 118 | in sortDoc (merge doc1 doc2) == sortDoc (merge doc1 doc2_nub) 119 | 120 | -- | Merge applied to document twice returns same thing 121 | propMergeIdempotent :: (Show f, IsField f, Eq f) => [f] -> [f] -> Bool 122 | propMergeIdempotent doc1 doc2 = 123 | let m1 = merge doc1 doc2 124 | m2 = merge m1 doc2 125 | in m1 == m2 126 | && (merge doc1 doc1 == doc1) 127 | && (merge doc2 doc2 == doc2) 128 | 129 | -- 130 | -- Test conversion to/from Data.Bson 131 | -- 132 | 133 | testMarshall :: Test 134 | testMarshall = testGroup "Marshalling HsonDocument" [ 135 | testProperty "Test marshalling to/from \"Data.Bson\"'s Document" 136 | testToFromDocuments 137 | ] 138 | 139 | -- | Test marshalling to/from "Data.Bson"'s Document 140 | -- Serializing all field names is buggy on the "Data.Bson" end. 141 | testToFromDocuments :: HsonDocument -> Bool 142 | testToFromDocuments d = 143 | let doc = filter (not . needsPolicy) . 144 | filter (not . T.null . fieldName) . clean $ d 145 | doc' = dataBsonDocToHsonDocTCB . hsonDocToDataBsonDocTCB $ doc 146 | in and $ zipWith veq doc doc' 147 | where 148 | veq v1@(HsonField _ (HsonValue _)) 149 | v2@(HsonField _ (HsonValue _)) = v1 == v2 150 | veq (HsonField n1 (HsonLabeled (HasPolicyTCB (LabeledTCB _ v1)))) 151 | (HsonField n2 (HsonLabeled (NeedPolicyTCB v2))) = 152 | n1 == n2 && v1 == v2 153 | veq _ _ = False 154 | needsPolicy (HsonField _ (HsonLabeled (NeedPolicyTCB _))) = True 155 | needsPolicy _ = False 156 | -------------------------------------------------------------------------------- /tests/HttpServerTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module HttpServerTests where 3 | 4 | import Test.Framework 5 | import Test.Framework.Providers.HUnit 6 | import Hails.HttpServer 7 | import Hails.Types 8 | import Network.HTTP.Types 9 | import qualified Network.Wai as W 10 | import Network.Wai.Test 11 | 12 | clearanceViolatingApp :: Application 13 | 14 | httpServerTests :: Test 15 | httpServerTests = testGroup "hailsApplication" 16 | [ testCase "Restricts current label" $ runSession (do 17 | resp <- request undefined 18 | assertHeader "TestHeader" "MyHeaderVal" resp) $ 19 | requireLoginMiddleware (responseLBS status301 [("TestHeader", "MyHeaderVal")] "") $ 20 | const . return $ responseLBS status401 [("x-hails-login", "yes")] "" 21 | ] 22 | 23 | -------------------------------------------------------------------------------- /tests/Tests.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Framework 4 | 5 | import qualified AuthTests 6 | import qualified HsonTests 7 | import qualified DatabaseTests 8 | 9 | main :: IO () 10 | main = defaultMain tests 11 | 12 | tests :: [Test] 13 | tests = AuthTests.tests ++ 14 | HsonTests.tests ++ 15 | DatabaseTests.tests 16 | --------------------------------------------------------------------------------