Merge branch 'feat/implicit-cryptoids' into 'master'

implicit cryptoids & uuid dispatch

See merge request !9

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
@@ -75,6 +77,8 @@ dependencies:
 - yesod-auth-ldap
 - LDAP
 - parsec
+- uuid
+- exceptions
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -29,5 +29,7 @@
 !/submission/archive/#FilePath SubmissionDownloadArchiveR GET
 !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
 
+!/#UUID CryptoUUIDDispatchR GET
+
 -- For demonstration
 /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

src/Application.hs

@@ -46,6 +46,7 @@ import Handler.Term
 import Handler.Course
 import Handler.Sheet
 import Handler.Submission
+import Handler.CryptoIDDispatch
 
 
 -- This line actually creates our YesodDispatch instance. It is the second half

src/CryptoID.hs

@@ -7,8 +7,9 @@
 
 module CryptoID
   ( module CryptoID
-  , module Data.UUID.Cryptographic
+  , module Data.CryptoID.Poly.ImplicitNamespace
-  , module Data.CryptoID.Poly
+  , 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.ImplicitNamespace
-import Data.CryptoID.Poly hiding (encrypt, decrypt)
+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"
+decCryptoIDs [ ''SubmissionId
-               , "Course"
+             , ''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]
+decCryptoIDs :: [Name] -> DecsQ
-decTypeAliases = return . concatMap decTypeAliases'
+decCryptoIDs = fmap concat . mapM decCryptoID
   where
-    decTypeAliases' :: String -> [Dec]
+    decCryptoID :: Name -> DecsQ
-    decTypeAliases' n
+    decCryptoID n@(conT -> t) = do
-      = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n)
+      instances <- [d|
-        , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID
+          instance Binary $(t) where
-        , TySynD cryptoBase32n [] $ ConT cryptoIDn `AppT` (ConT ''CI `AppT` ConT ''FilePath)
+            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
+        ns = (\nb -> fromMaybe nb $ stripSuffix "Id" nb) $ nameBase n
-        cryptoUUIDn = mkName $ "CryptoUUID" ++ n
+        cryptoIDSyn (ct, str) = tySynD (mkName $ "Crypto" ++ str ++ ns) [] $ conT ''CryptoID `appT` return ct `appT` t
-        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
-          |]

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
@@ -133,6 +132,7 @@ instance Yesod UniWorX where
     isAuthorized  CourseListR        _ = return Authorized
     isAuthorized (CourseListTermR _) _ = return Authorized
     isAuthorized (CourseShowR _ _)   _ = return Authorized
+    isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized
     isAuthorized  SubmissionListR    _ = isAuthenticated
     isAuthorized  SubmissionDownloadMultiArchiveR _ = isAuthenticated
 --     isAuthorized  TestR        _ = return Authorized
@@ -186,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 <- decrypt cID
-  courseId <- UUID.decrypt cIDKey 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 decrypt decrypt cID
-  submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID
   Submission{..} <- get404 submissionId
   submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] []
   let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy
@@ -427,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

@@ -0,0 +1,62 @@
+{-# LANGUAGE NoImplicitPrelude
+           , DataKinds
+           , KindSignatures
+           , TypeFamilies
+           , FlexibleInstances
+           , TypeOperators
+           , RankNTypes
+           , PolyKinds
+           , RecordWildCards
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+           , ViewPatterns
+  #-}
+
+module Handler.CryptoIDDispatch
+  ( getCryptoUUIDDispatchR
+  ) where
+
+import Import hiding (Proxy)
+
+import Data.Proxy
+
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
+
+import qualified Control.Monad.Catch as E (Handler(..))
+
+
+class CryptoRoute ciphertext plaintext where
+  cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
+
+instance CryptoRoute UUID SubmissionId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (_ :: SubmissionId) <- decrypt cID
+    
+    return $ SubmissionR cID
+
+
+class Dispatch ciphertext (x :: [*]) where
+  dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
+
+instance Dispatch ciphertext '[] where
+  dispatchID _ _ = return Nothing
+
+instance (CryptoRoute ciphertext plaintext, Dispatch ciphertext ps) => Dispatch ciphertext (plaintext ': ps) where
+  dispatchID _ ciphertext = (<|>) <$> dispatchHead <*> dispatchTail
+    where
+      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 ps) ciphertext
+  
+
+getCryptoUUIDDispatchR :: UUID -> Handler ()
+getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
+  where
+    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 <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
-                        sId <- FilePath.decrypt cIDKey (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 <- decrypt cID
-  submissionID <- UUID.decrypt cIDKey cID
+  cID' <- encrypt submissionID
-  cID' <- FilePath.encrypt cIDKey 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
+            cID <- encrypt submissionID
-              cIDKey <- getsYesod appCryptoIDKey
-              FilePath.encrypt cIDKey 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 <- decrypt cID
-  submissionID <- FilePath.decrypt cIDKey cID
+  cUUID <- encrypt submissionID
-  cUUID <- UUID.encrypt cIDKey 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 <- decrypt cID
-  submissionId <- UUID.decrypt cIDKey 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"

src/Import/NoFoundation.hs

@@ -14,3 +14,4 @@ import Yesod.Default.Config2 as Import
 import Data.Fixed            as Import
 
 import CryptoID              as Import
+import Data.UUID             as Import (UUID)

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
+- uuid-crypto-1.4.0.0
-- filepath-crypto-0.0.0.0
+- filepath-crypto-0.1.0.0
-- cryptoids-0.4.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