WIP: add start of validation work

api-dungeon-studio.cabal

@@ -64,6 +64,7 @@ executable api-dungeon-studio
     , Internal.BoltPool.Environment
     , Internal.JWT.Environment
     , Internal.Network.URI
+    , Internal.Network.URI.Validation
     , Settings
 
   build-depends:
@@ -95,6 +96,7 @@ executable api-dungeon-studio
     , time                 == 1.6.*
     , unordered-containers == 0.2.*
     , uuid                 == 1.3.*
+    , validation           == 0.5.*
     , wai                  == 3.2.*
     , wai-cors             == 0.2.*
     , wai-logger           == 2.3.*

default.nix

@@ -1,10 +1,11 @@
 { mkDerivation, aeson, base, bytestring, connection, containers
-, data-default, envy, exceptions, hasbolt, hspec, http-api-data
-, http-conduit, http-media, http-types, ieee754, jose, lens, mtl
-, network-arbitrary, network-uri, network-uri-json, QuickCheck
-, quickcheck-instances, regex-compat, resource-pool, retry, servant
-, servant-server, siren-json, stdenv, test-invariant, text, time
-, unordered-containers, uuid, wai, wai-cors, wai-logger, warp
+, data-default, envy, exceptions, hasbolt, hspec, hspec-discover
+, http-api-data, http-conduit, http-media, http-types, ieee754
+, jose, lens, mtl, network-arbitrary, network-uri, network-uri-json
+, QuickCheck, quickcheck-instances, regex-compat, resource-pool
+, retry, servant, servant-server, siren-json, stdenv
+, test-invariant, text, time, unordered-containers, uuid
+, validation, wai, wai-cors, wai-logger, warp
 }:
 mkDerivation {
   pname = "api-dungeon-studio";
@@ -17,7 +18,7 @@ mkDerivation {
     exceptions hasbolt http-api-data http-conduit http-media http-types
     jose lens mtl network-uri network-uri-json regex-compat
     resource-pool retry servant servant-server siren-json text time
-    unordered-containers uuid wai wai-cors wai-logger warp
+    unordered-containers uuid validation wai wai-cors wai-logger warp
   ];
   testHaskellDepends = [
     aeson base envy exceptions hspec http-api-data http-media
@@ -26,6 +27,7 @@ mkDerivation {
     servant-server siren-json test-invariant text time
     unordered-containers
   ];
+  testToolDepends = [ hspec-discover ];
   homepage = "https://github.com/alunduil/api.dungeon.studio";
   description = "Game Master's Companion";
   license = stdenv.lib.licenses.mit;

src/Characters/Queries.hs

@@ -66,10 +66,7 @@ instance Exception CharacterException
 
 -- | Retrieve all 'Character's.
 all :: (MonadIO m, MonadCatch m) => Pool Pipe -> Text -> m (URI -> [Link] -> Characters)
-all p o =
-  do cs <- mapM (toCharacter <=< (`at` "c")) =<< q p cypher ps
-     return $ flip Characters cs
-
+all p o = flip Characters <$> mapM (toCharacter <=< (`at` "c")) =<< q p cypher ps
   where cypher :: Text
         cypher = "MATCH (c:Character)<-[:OWNS|:CAN_READ]-(:Owner {sub:{sub}}) " <>
                  "RETURN c"

src/Characters/Types.hs

@@ -94,8 +94,8 @@ instance ToEntity Character where
 
 -- | Earthdawn new character representation type.
 data NewCharacter = NewCharacter
-  { nDiscipline :: URI
-  , nRace       :: URI
+  { nDiscipline :: AbsoluteURI
+  , nRace       :: AbsoluteURI
   }
 
 instance FromForm NewCharacter where

test/External/Servant/API/BearerAuth/InternalSpec.hs

@@ -33,19 +33,19 @@ spec =
 
        it "should throw InvalidToken \"sub claim invalid\"" $
          let cs = emptyClaimsSet &
-                    claimSub .~ Just "mailto://[email protected]"
+                    claimSub ?~ "mailto://[email protected]"
          in claims nullURI cs `shouldThrow` invalidToken "sub claim invalid"
 
        it "should throw InvalidToken \"scope claim missing\"" $
          let cs = emptyClaimsSet &
-                    claimSub .~ Just "[email protected]"
+                    claimSub ?~ "[email protected]"
          in claims nullURI cs `shouldThrow` invalidToken "scope claim missing"
 
        it "should throw InvalidToken \"scope claim invalid\"" pending
 
        it "should return valid Claims" $
          let cs = emptyClaimsSet &
-                    claimSub .~ Just "subject" &
+                    claimSub ?~ "subject" &
                     unregisteredClaims .~ HashMap.fromList [ ("scope", String "s1 s2") ]
          in claims nullURI cs `shouldReturn` Claims { sub = "subject", scope = [ "s1", "s2" ], audience = nullURI }