Prototype of !token

haddock.sh

@@ -1,3 +1,14 @@
 #!/usr/bin/env bash
 
-exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
+move-back() {
+    mv -v .stack-work .stack-work-doc
+    [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
+}
+
+if [[ -d .stack-work-doc ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
+    mv -v .stack-work-doc .stack-work
+    trap move-back EXIT
+fi
+
+stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal

messages/uniworx/de.msg

@@ -203,6 +203,10 @@ CorrectorAssignTitle: Korrektor zuweisen
 Unauthorized: Sie haben hierfür keine explizite Berechtigung.
 UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
 UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
+UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. 
+UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
+UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
+UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
 UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
@@ -698,6 +702,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate
 AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
 AuthTagFree: Seite ist universell zugänglich
 AuthTagAdmin: Nutzer ist Administrator
+AuthTagToken: Nutzer präsentiert Authorisierungs-Token
 AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
 AuthTagDeprecated: Seite ist nicht überholt
 AuthTagDevelopment: Seite ist nicht in Entwicklung

src/Foundation.hs

@@ -15,6 +15,7 @@ import Auth.LDAP
 import Auth.PWHash
 import Auth.Dummy
 import Jobs.Types
+import Model.Token
 
 import qualified Network.Wai as W (pathInfo)
 
@@ -43,6 +44,7 @@ import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map, (!?))
 import qualified Data.Map as Map
+import qualified Data.HashSet as HashSet
 
 import Data.List (nubBy)
 
@@ -396,6 +398,17 @@ appLanguagesOpts = do
 
 
 -- Access Control
+newtype InvalidAuthTag = InvalidAuthTag Text
+  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+instance Exception InvalidAuthTag
+
+data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+instance Universe SessionAuthTags
+instance Finite SessionAuthTags
+nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
+
+
 data AccessPredicate
   = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
   | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult)
@@ -460,6 +473,26 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
     adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
     guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
     return Authorized
+tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ do
+  jwt <- maybeTMExceptT (unauthorizedI MsgUnauthorizedNoToken) $ asum
+    [ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
+    , MaybeT $ lookupGlobalPostParam PostToken
+    , MaybeT $ lookupGlobalGetParam GetToken
+    ]
+  BearerToken{..} <- catch (decodeToken jwt) $ \case
+    BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
+    BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
+    other -> throwM other
+  unless (maybe True (HashSet.member route) tokenRoutes) $
+    throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidRoute
+  authorityVal <- evalAccessFor (Just tokenAuthority) route isWrite
+  unless (is _Authorized authorityVal) $
+    throwError authorityVal
+  whenIsJust tokenAddAuth $ \addDNF -> do
+    additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) addDNF mAuthId route isWrite
+    unless (is _Authorized additionalVal) $
+      throwError additionalVal
+  return Authorized
 tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
   AdminHijackUserR cID -> exceptT return return $ do
     myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -714,27 +747,21 @@ tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorize
 tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
 
 
-newtype InvalidAuthTag = InvalidAuthTag Text
+defaultAuthDNF :: AuthDNF
-  deriving (Eq, Ord, Show, Read, Generic, Typeable)
+defaultAuthDNF = PredDNF $ Set.fromList
-instance Exception InvalidAuthTag
+  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
+  , impureNonNull . Set.singleton $ PLVariable AuthToken
+  ]
 
-type DNF a = Set (NonNull (Set a))
+routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
-
-data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Universe SessionAuthTags
-instance Finite SessionAuthTags
-nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1)
-
-routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
 -- ^ DNF up to entailment:
 --
 -- > (A_1 && A_2 && ...) OR' B OR' ...
 --
 -- > A OR' B := ((A |- B) ==> A) && (A || B)
-routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs
+routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
   where
-    partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
+    partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
     partition' prev t
       | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
         = if
@@ -745,9 +772,9 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p
       | otherwise
         = Left $ InvalidAuthTag t
 
-evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
 -- ^ `tell`s disabled predicates, identified as pivots
-evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) mAuthId route isWrite
+evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite
   = do
       mr <- getMsgRenderer
       let
@@ -760,23 +787,31 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
               $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
               evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
 
+        evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
+        evalAuthLiteral PLVariable{..} = evalAuthTag plVar
+        evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case
+          Unauthorized _         -> return Authorized
+          AuthenticationRequired -> return AuthenticationRequired
+          Authorized             -> unauthorizedI plVar
+
         orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
         orAR' = shortCircuitM (is _Authorized) (orAR mr)
         andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
 
-        evalDNF :: [[AuthTag]] -> WriterT (Set AuthTag) m AuthResult
+        evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
-        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
+        evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
 
-      $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
+      $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF
 
-      result <- evalDNF $ filter (all authTagIsActive) authDNF
+      result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
 
-      unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
+      unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
-        whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
+        whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
-          let pivots = filter authTagIsInactive conj
+          let pivots = filter (authTagIsInactive . plVar) conj
-          whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
+          whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
-            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
+            let pivots' = plVar <$> pivots
-            tell $ Set.fromList pivots
+            $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
+            tell $ Set.fromList pivots'
 
       return result
 

src/Jose/Jwt/Instances.hs

@@ -13,6 +13,7 @@ instance PathPiece Jwt where
   toPathPiece (Jwt bytes) = decodeUtf8 bytes
   fromPathPiece = Just . Jwt . encodeUtf8
 
+deriving instance Generic JwtError
 deriving instance Typeable JwtError
 
 instance Exception JwtError

src/Model/Token.hs

@@ -3,28 +3,26 @@
 module Model.Token
   ( BearerToken(..)
   , bearerToken
-  , encodeToken, decodeToken
+  , encodeToken, BearerTokenException(..), decodeToken
-  , tokenToJSON, tokenParseJSON
+  , tokenToJSON, tokenParseJSON, tokenParseJSON'
   ) where
 
 import ClassyPrelude.Yesod
 import Model
 import Settings
+import Utils (NTop(..))
 import Utils.Lens hiding ((.=))
 
 import Yesod.Auth (AuthId)
 
--- import qualified Jose.Jwa as Jose
+import qualified Jose.Jwa as Jose
-import Jose.Jwk (JwkSet)
+import Jose.Jwk (JwkSet(..))
--- import qualified Jose.Jwk as Jose
+import Jose.Jwt (Jwt(..), IntDate(..))
-import Jose.Jwt (Jwt, JwtError, IntDate(..))
 import qualified Jose.Jwt as Jose
 
 import Jose.Jwt.Instances ()
 import Data.Aeson.Types.Instances ()
 
-import qualified Crypto.Random as Crypto (MonadRandom)
-
 import Data.HashSet (HashSet)
 
 import qualified Data.HashMap.Strict as HashMap
@@ -32,6 +30,9 @@ import qualified Data.HashMap.Strict as HashMap
 import Data.Aeson.Types (Parser, (.:?), (.:))
 import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
+import qualified Data.Aeson.Parser as JSON
+import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
+import qualified Data.Aeson.Internal as JSON (iparse, formatError)
 
 import CryptoID
 
@@ -42,10 +43,10 @@ import Control.Monad.Random (MonadRandom(..))
 
 
 data BearerToken site = BearerToken
-  { tokenIdentifier :: TokenId
+  { tokenIdentifier :: TokenId -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
-  , tokenAuthority  :: AuthId site
+  , tokenAuthority  :: AuthId site -- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
-  , tokenRoutes     :: Maybe (HashSet (Route site))
+  , tokenRoutes     :: Maybe (HashSet (Route site)) -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
-  , tokenAddAuth    :: AuthCNF
+  , tokenAddAuth    :: Maybe AuthDNF -- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
   , tokenIssuedAt   :: UTCTime
   , tokenIssuedBy   :: InstanceId
   , tokenExpiresAt
@@ -73,10 +74,11 @@ tokenToJSON BearerToken{..} = do
         , jwtJti = Just $ toPathPiece tokenIdentifier
         }
   return . JSON.object $
-    [ "authority" .= cID
+    catMaybes [ Just $ "authority" .= cID
-    , "routes"    .= tokenRoutes
+              , ("routes" .=) <$> tokenRoutes
-    , "add-auth"  .= tokenAddAuth
+              , ("add-auth" .=) <$> tokenAddAuth
-    ] ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
+              ]
+    ++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
 
 tokenParseJSON :: forall site.
                   ( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
@@ -90,7 +92,7 @@ tokenParseJSON v@(Object o) = do
   tokenAuthority <- decrypt tokenAuthority'
 
   tokenRoutes    <- lift $ o .:? "routes"
-  tokenAddAuth   <- lift $ o .:  "add-auth"
+  tokenAddAuth   <- lift $ o .:? "add-auth"
   Jose.JwtClaims{..} <- lift $ parseJSON v
 
   let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
@@ -104,6 +106,19 @@ tokenParseJSON v@(Object o) = do
   return BearerToken{..}
 tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v
 
+tokenParseJSON' :: forall m.
+                  ( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+                  , ParseRoute (HandlerSite m)
+                  , Hashable (Route (HandlerSite m))
+                  , MonadHandler m
+                  , MonadCrypto m
+                  , MonadCryptoKey m ~ CryptoIDKey
+                  )
+               => m (Value -> Parser (BearerToken (HandlerSite m)))
+tokenParseJSON' = do
+  cidKey <- cryptoIDKey return
+  return $ flip runReaderT cidKey . tokenParseJSON
+
 
 bearerToken :: forall m.
                ( MonadHandler m
@@ -113,7 +128,7 @@ bearerToken :: forall m.
                )
             => AuthId (HandlerSite m)
             -> Maybe (HashSet (Route (HandlerSite m)))
-            -> AuthCNF
+            -> Maybe AuthDNF
             -> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
             -> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
             -> m (BearerToken (HandlerSite m))
@@ -135,9 +150,12 @@ bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsA
   return BearerToken{..}
 
 
+jwtEncoding :: Jose.JwtEncoding
+jwtEncoding = Jose.JwsEncoding Jose.HS256
+
+
 encodeToken :: forall m.
-               ( Crypto.MonadRandom m
+               ( MonadHandler m
-               , MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
                , HasInstanceID (HandlerSite m) InstanceId
                , HasCryptoUUID (AuthId (HandlerSite m)) m
@@ -145,14 +163,43 @@ encodeToken :: forall m.
                )
             => BearerToken (HandlerSite m) -> m Jwt
 encodeToken token = do
-  _payload <- tokenToJSON token
+  payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
-  error "Not implemented"
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
+
+
+data BearerTokenException
+  = BearerTokenJwtError Jose.JwtError
+  | BearerTokenUnsecured
+  | BearerTokenInvalidFormat String
+  | BearerTokenExpired | BearerTokenNotStarted
+  deriving (Eq, Show, Generic, Typeable)
+
+instance Exception BearerTokenException
 
 decodeToken :: forall m.
-               ( Crypto.MonadRandom m
+               ( MonadHandler m
-               , MonadHandler m
                , HasJSONWebKeySet (HandlerSite m) JwkSet
-               , HasCryptoUUID (AuthId (HandlerSite m)) m
+               , HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
+               , MonadCryptoKey m ~ CryptoIDKey
+               , MonadCrypto m
+               , MonadThrow m
+               , ParseRoute (HandlerSite m)
+               , Hashable (Route (HandlerSite m))
                )
-            => Jwt -> m (Either JwtError (BearerToken (HandlerSite m)))
+            => Jwt -> m (BearerToken (HandlerSite m))
-decodeToken = error "Not implemented"
+decodeToken (Jwt bs) = do
+  JwkSet jwks <- getsYesod $ view jsonWebKeySet
+  content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
+  content' <- case content of
+    Jose.Unsecured _ -> throwM BearerTokenUnsecured
+    Jose.Jws (_header, payload) -> return payload
+    Jose.Jwe (_header, payload) -> return payload
+  parser <- tokenParseJSON'
+  token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
+  now <- liftIO getCurrentTime
+  unless (NTop tokenExpiresAt > NTop (Just now)) $
+    throwM BearerTokenExpired
+  unless (tokenStartsAt <= Just now) $
+    throwM BearerTokenNotStarted
+  return token

src/Model/Types.hs

@@ -714,6 +714,7 @@ pseudonymFragments = folding
 
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
+  | AuthToken
   | AuthLecturer
   | AuthCorrector
   | AuthRegistered
@@ -786,28 +787,27 @@ deriveJSON defaultOptions
   , unwrapUnaryRecords = True
   } ''PredLiteral
 
+instance PathPiece a => PathPiece (PredLiteral a) where
+  toPathPiece PLVariable{..} = toPathPiece plVar
+  toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
 
-newtype PredCNF a = PredCNF (Set (NonNull (Set (PredLiteral a))))
+  fromPathPiece t = PLVariable <$> fromPathPiece t
-  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+                <|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
-  deriving newtype (Semigroup, Monoid)
 
-newtype PredDNF a = PredDNF (Set (NonNull (Set (PredLiteral a))))
+
+newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving newtype (Semigroup, Monoid)
 
 $(return [])
 
-instance (Ord a, ToJSON a) => ToJSON (PredCNF a) where
-  toJSON = $(mkToJSON predNFAesonOptions ''PredCNF)
-instance (Ord a, FromJSON a) => FromJSON (PredCNF a) where
-  parseJSON = $(mkParseJSON predNFAesonOptions ''PredCNF)
- 
 instance (Ord a, ToJSON a) => ToJSON (PredDNF a) where
   toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
 instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
   parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
 
-type AuthCNF = PredCNF AuthTag
+type AuthLiteral = PredLiteral AuthTag
+
 type AuthDNF = PredDNF AuthTag
 
 

src/Utils.hs

@@ -490,6 +490,12 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
 maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
 maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
 
+maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
+maybeTExceptT err act = maybeExceptT err $ runMaybeT act
+  
+maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
+maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
+
 whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
 whenExceptT b err = when b $ throwE err
 

src/Utils/Parameters.hs

@@ -20,7 +20,7 @@ import Data.Universe
 import Control.Monad.Trans.Maybe (MaybeT(..))
 
 
-data GlobalGetParam = GetReferer
+data GlobalGetParam = GetReferer | GetToken
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalGetParam
@@ -51,6 +51,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
 data GlobalPostParam = PostFormIdentifier
                      | PostDeleteTarget
                      | PostMassInputShape
+                     | PostToken
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 instance Universe GlobalPostParam

src/Yesod/Core/Instances.hs

@@ -68,6 +68,9 @@ instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
   put = Binary.put . toPathPiece
   get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
 
+instance RenderRoute site => Hashable (Route site) where
+  hashWithSalt s = hashWithSalt s . routeToPathPiece
+
 
 instance Monad FormResult where
   (FormSuccess a)    >>= f = f a

test/Database.hs

@@ -24,7 +24,7 @@ import qualified Data.ByteString as BS
 
 import Data.Time
 
-import Utils.Lens (review)
+import Utils.Lens (review, view)
 import Control.Monad.Random.Class (MonadRandom(..))
 
 
@@ -82,7 +82,7 @@ insertFile fileTitle = do
 
 fillDb :: DB ()
 fillDb = do
-  AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
+  AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod $ view appSettings
   now <- liftIO getCurrentTime
   let
     insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)