Make CryptoIDKey implicit using new cryptoids-class

ghci.sh

@@ -0,0 +1,8 @@
+#!/usr/bin/env bash
+
+unset HOST
+export DETAILED_LOGGING=true
+export LOG_ALL=true
+export DUMMY_LOGIN=true
+
+exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only

package.yaml

@@ -10,6 +10,7 @@ dependencies:
 # version 1.0 had a bug in reexporting Handler, causing trouble
 - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1
 
+- foreign-store
 - yesod >=1.4.3 && <1.5
 - yesod-core >=1.4.30 && <1.5
 - yesod-auth >=1.4.0 && <1.5
@@ -64,6 +65,7 @@ dependencies:
 - filepath-crypto
 - cryptoids-types
 - cryptoids
+- cryptoids-class
 - binary
 - mtl
 - sandi

src/CryptoID.hs

@@ -7,8 +7,9 @@
 
 module CryptoID
   ( module CryptoID
-  , module Data.UUID.Cryptographic
-  , module Data.CryptoID.Poly
+  , module Data.CryptoID.Poly.ImplicitNamespace
+  , module Data.UUID.Cryptographic.ImplicitNamespace
+  , module System.FilePath.Cryptographic.ImplicitNamespace
   ) where
 
 import CryptoID.TH
@@ -16,10 +17,10 @@ import CryptoID.TH
 import ClassyPrelude hiding (fromString)
 import Model
 
-import Data.CryptoID
-import Data.CryptoID.Poly hiding (encrypt, decrypt)
+import Data.CryptoID.Poly.ImplicitNamespace
+import Data.UUID.Cryptographic.ImplicitNamespace
+import System.FilePath.Cryptographic.ImplicitNamespace
 
-import Data.UUID.Cryptographic
 import Data.UUID.Types
 import Web.PathPieces
 
@@ -28,10 +29,7 @@ instance PathPiece UUID where
   fromPathPiece = fromString . unpack
   toPathPiece = pack . toString
 
-decKeysBinary [ ''SubmissionId
-              , ''CourseId
-              ]
 
-decTypeAliases [ "Submission"
-               , "Course"
-               ]
+decCryptoIDs [ ''SubmissionId
+             , ''CourseId
+             ]

src/CryptoID/TH.hs

@@ -8,7 +8,7 @@ import ClassyPrelude
 
 import Language.Haskell.TH
 
-import Data.CryptoID (CryptoID)
+import Data.CryptoID.Class.ImplicitNamespace
 import Data.UUID.Types (UUID)
 import Data.Binary (Binary(..))
 import Data.Binary.SerializationLength
@@ -19,28 +19,30 @@ import System.FilePath (FilePath)
 import Database.Persist.Sql (toSqlKey, fromSqlKey)
 
 
-decTypeAliases :: [String] -> Q [Dec]
-decTypeAliases = return . concatMap decTypeAliases'
+decCryptoIDs :: [Name] -> DecsQ
+decCryptoIDs = fmap concat . mapM decCryptoID
   where
-    decTypeAliases' :: String -> [Dec]
-    decTypeAliases' n
-      = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n)
-        , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID
-        , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath)
+    decCryptoID :: Name -> DecsQ
+    decCryptoID n@(conT -> t) = do
+      instances <- [d|
+          instance Binary $(t) where
+            get = $(varE 'toSqlKey) <$> get
+            put = put . $(varE 'fromSqlKey)
+          instance HasFixedSerializationLength $(t) where
+            type SerializationLength $(t) = SerializationLength Int64
+
+          type instance CryptoIDNamespace a $(t) = $(litT $ strTyLit ns)
+        |]
+
+      synonyms <- mapM cryptoIDSyn
+        [ (ConT ''UUID, "UUID")
+        , (ConT ''CI `AppT` ConT ''FilePath, "FileName")
+        ]
+
+      return $ concat
+        [ instances
+        , synonyms
         ]
       where
-        cryptoIDn = mkName $ "CryptoID" ++ n
-        cryptoUUIDn = mkName $ "CryptoUUID" ++ n
-        cryptoBase32n = mkName $ "CryptoFileName" ++ n
-
-decKeysBinary :: [Name] -> DecsQ
-decKeysBinary = fmap concat . mapM decKeyBinary
-  where
-    decKeyBinary :: Name -> DecsQ
-    decKeyBinary (conT -> t)
-      = [d| instance Binary $(t) where
-              get = $(varE 'toSqlKey) <$> get
-              put = put . $(varE 'fromSqlKey)
-            instance HasFixedSerializationLength $(t) where
-              type SerializationLength $(t) = SerializationLength Int64
-          |]
+        ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
+        cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t

src/Foundation.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 
 module Foundation where
 
@@ -48,8 +49,6 @@ import Data.Conduit.List (sourceList)
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Handler.Utils.StudyFeatures
 
-import qualified Data.UUID.Cryptographic as UUID
-import qualified System.FilePath.Cryptographic as FilePath
 import System.FilePath
 
 -- | The foundation datatype for your application. This can be a good place to
@@ -187,16 +186,14 @@ isAuthorizedDB (TermEditExistR _)     _ = adminAccess Nothing
 isAuthorizedDB CourseEditR            _ = lecturerAccess Nothing
 isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c)
 isAuthorizedDB (CourseEditExistIDR cID) _ = do
-  cIDKey <- getsYesod appCryptoIDKey
-  courseId <- UUID.decrypt cIDKey cID
+  courseId <- decrypt cID
   courseLecturerAccess courseId
 isAuthorizedDB route isWrite = return  $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
 
 submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult
 submissionAccess cID = do
   authId <- lift requireAuthId
-  cIDKey <- getsYesod appCryptoIDKey
-  submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID
+  submissionId <- either decrypt decrypt cID
   Submission{..} <- get404 submissionId
   submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] []
   let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy
@@ -428,6 +425,11 @@ instance HasHttpManager UniWorX where
 unsafeHandler :: UniWorX -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 
+
+instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
+  type MonadCryptoKey m = CryptoIDKey
+  cryptoIDKey f = getsYesod appCryptoIDKey >>= f
+
 -- Note: Some functionality previously present in the scaffolding has been
 -- moved to documentation in the Wiki. Following are some hopefully helpful
 -- links:

src/Handler/CryptoIDDispatch.hs

@@ -9,59 +9,54 @@
            , RecordWildCards
            , MultiParamTypeClasses
            , ScopedTypeVariables
+           , ViewPatterns
   #-}
 
 module Handler.CryptoIDDispatch
   ( getCryptoUUIDDispatchR
   ) where
 
-import GHC.TypeLits
 import Import hiding (Proxy)
 
 import Data.Proxy
 
-import qualified Data.UUID.Cryptographic as UUID
-
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import qualified Control.Monad.Catch as E (Handler(..))
 
 
-class KnownSymbol namespace => CryptoRoute ciphertext namespace where
-  cryptoIDRoute :: CryptoID namespace ciphertext -> Handler (Route UniWorX)
+class CryptoRoute ciphertext plaintext where
+  cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
 
-instance CryptoRoute UUID "Submission" where
-  cryptoIDRoute cID = do
-    cIDKey <- getsYesod appCryptoIDKey
-    (_ :: SubmissionId) <- UUID.decrypt cIDKey cID
+instance CryptoRoute UUID SubmissionId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (_ :: SubmissionId) <- decrypt cID
     
     return $ SubmissionR cID
 
 
-class Dispatch ciphertext (x :: [Symbol]) where
+class Dispatch ciphertext (x :: [*]) where
   dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
 
 instance Dispatch ciphertext '[] where
   dispatchID _ _ = return Nothing
 
-instance (CryptoRoute ciphertext namespace, Dispatch ciphertext ns) => Dispatch ciphertext (namespace ': ns) where
+instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where
   dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail
     where
-      headID :: CryptoID namespace ciphertext
-      headID = CryptoID{..}
-      dispatchHead = (Just <$> cryptoIDRoute headID) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ]
+      dispatchHead = (Just <$> cryptoIDRoute (Proxy :: Proxy plaintext) ciphertext) `catches` [ E.Handler handleHCError, E.Handler handleCryptoID ]
         where
           handleHCError :: HandlerContents -> Handler (Maybe a)
           handleHCError (HCError NotFound) = return Nothing
           handleHCError e = throwM e
           handleCryptoID :: CryptoIDError -> Handler (Maybe a)
           handleCryptoID _ = return Nothing
-      dispatchTail = dispatchID (Proxy :: Proxy ns) ciphertext
+      dispatchTail = dispatchID (Proxy :: Proxy ps) ciphertext
   
 
 getCryptoUUIDDispatchR :: UUID -> Handler ()
 getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
   where
-    p :: Proxy '[ "Submission"
+    p :: Proxy '[ SubmissionId
                 ]
     p = Proxy

src/Handler/Submission.hs

@@ -27,8 +27,6 @@ import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.CaseInsensitive as CI
 
-import qualified Data.UUID.Cryptographic as UUID
-
 import qualified Database.Esqueleto as E
 
 import qualified Data.Conduit.List as Conduit
@@ -38,7 +36,6 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 import System.FilePath
-import qualified System.FilePath.Cryptographic as FilePath (decrypt, encrypt)
 
 import Colonnade
 import Yesod.Colonnade
@@ -52,9 +49,8 @@ submissionTable = do
 
     return (sub, sheet, course)
 
-  cIDKey <- getsYesod appCryptoIDKey
   cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
-    (,,) <$> FilePath.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s
+    (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
 
   let
     anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand
@@ -69,7 +65,7 @@ submissionTable = do
     toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
     toExternal (_, cID, _) = return cID
     fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
-    fromExternal = UUID.decrypt cIDKey
+    fromExternal = decrypt
   headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
 
 
@@ -106,8 +102,7 @@ postSubmissionListR = do
                 (Left f@File{..})  -> case splitDirectories fileTitle of
                   (cID:rest)
                     | not (null rest) -> do
-                        cIDKey <- getsYesod appCryptoIDKey
-                        sId <- FilePath.decrypt cIDKey (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
+                        sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
                         lift . feed sId $ Left f{ fileTitle = joinPath rest }
                     | otherwise -> return ()
                   [] -> invalidArgs ["Encountered file/directory with empty name"]
@@ -121,9 +116,8 @@ postSubmissionListR = do
 
 getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
 getSubmissionDownloadSingleR cID path = do
-  cIDKey <- getsYesod appCryptoIDKey
-  submissionID <- UUID.decrypt cIDKey cID
-  cID' <- FilePath.encrypt cIDKey submissionID
+  submissionID <- decrypt cID
+  cID' <- encrypt submissionID
 
   runDB $ do
     isRating <- maybe False (== submissionID) <$> isRatingFile path
@@ -172,9 +166,7 @@ postSubmissionDownloadMultiArchiveR = do
         let
           fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
           fileEntitySource' (rating, Entity submissionID Submission{..}) = do
-            cID <- lift $ do
-              cIDKey <- getsYesod appCryptoIDKey
-              FilePath.encrypt cIDKey submissionID
+            cID <- encrypt submissionID
 
             let
               directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
@@ -202,9 +194,8 @@ getSubmissionDownloadArchiveR path = do
       cID :: CryptoFileNameSubmission
       cID = CryptoID $ CI.mk baseName
   unless (ext == ".zip") notFound
-  cIDKey <- getsYesod appCryptoIDKey
-  submissionID <- FilePath.decrypt cIDKey cID
-  cUUID <- UUID.encrypt cIDKey submissionID
+  submissionID <- decrypt cID
+  cUUID <- encrypt submissionID
   respondSourceDB "application/zip" $ do
     rating <- lift $ getRating submissionID
     case rating of
@@ -218,8 +209,7 @@ getSubmissionDownloadArchiveR path = do
 getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
 getSubmissionR = postSubmissionR
 postSubmissionR cID = do
-  cIDKey <- getsYesod appCryptoIDKey
-  submissionId <- UUID.decrypt cIDKey cID
+  submissionId <- decrypt cID
   
   ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
     <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False)
@@ -260,7 +250,7 @@ postSubmissionR cID = do
       , ratingTime = submissionRatingTime submission
       }
 
-  cID' <- FilePath.encrypt cIDKey submissionId
+  cID' <- encrypt submissionId
   let
     archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
     archiveName = archiveBaseName <.> "zip"

stack.yaml

@@ -26,13 +26,15 @@ extra-deps:
 - yesod-colonnade-1.1.0
 # - zip-stream-0.1.0.1
 - conduit-resumablesink-0.2
-- uuid-crypto-1.3.1.0
-- filepath-crypto-0.0.0.0
-- cryptoids-0.4.0.0
+- uuid-crypto-1.4.0.0
+- filepath-crypto-0.1.0.0
+- cryptoids-0.5.0.0
 - cryptoids-types-0.0.0
+- cryptoids-class-0.0.0
 
 - encoding-0.8.2
 - regex-compat-0.93.1
 
 - LDAP-0.6.11
 resolver: lts-9.3
+allow-newer: true