Bind to cryptoids

.gitignore

@@ -2,6 +2,7 @@ dist*
 static/tmp/
 static/combined/
 client_session_key.aes
+cryptoid_key.bf
 *.hi
 *.o
 *.sqlite3

config/settings.yml

@@ -32,5 +32,7 @@ database:
   database: "_env:PGDATABASE:uniworx"
   poolsize: "_env:PGPOOLSIZE:10"
 
+cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
+
 copyright: Insert copyright statement here
 #analytics: UA-YOURCODE

package.yaml

@@ -58,6 +58,13 @@ dependencies:
 - filepath
 - transformers
 - wl-pprint-text
+- uuid-types
+- path-pieces
+- uuid-crypto
+- cryptoids-types
+- cryptoids
+- binary
+- mtl
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -18,3 +18,5 @@
 /course/#TermIdentifier/#Text/edit CourseEditExistR GET
 /course/#TermIdentifier/#Text/show CourseShowR GET
 
+-- For demonstration
+/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

src/Application.hs

@@ -55,14 +55,16 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
 -- the place to put your migrate statements to have automatic database
 -- migrations handled by Yesod.
 makeFoundation :: AppSettings -> IO UniWorX
-makeFoundation appSettings = do
+makeFoundation appSettings@(AppSettings{..}) = do
     -- Some basic initializations: HTTP connection manager, logger, and static
     -- subsite.
     appHttpManager <- newManager
     appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
     appStatic <-
-        (if appMutableStatic appSettings then staticDevel else static)
-        (appStaticDir appSettings)
+        (if appMutableStatic then staticDevel else static)
+        appStaticDir
+
+    appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
 
     -- We need a log function to create a connection pool. We need a connection
     -- pool to create our foundation. And we need our foundation to get a
@@ -78,8 +80,8 @@ makeFoundation appSettings = do
 
     -- Create the database connection pool
     pool <- flip runLoggingT logFunc $ createPostgresqlPool
-        (pgConnStr  $ appDatabaseConf appSettings)
-        (pgPoolSize $ appDatabaseConf appSettings)
+        (pgConnStr  appDatabaseConf)
+        (pgPoolSize appDatabaseConf)
 
     -- Perform database migration using our application's logging settings.
     runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc

src/CryptoID.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module CryptoID
+  ( module CryptoID
+  , module Data.UUID.Cryptographic
+  , module Data.CryptoID.Poly
+  ) where
+
+import CryptoID.TH
+
+import ClassyPrelude hiding (fromString)
+import Model
+
+import Data.CryptoID
+import Data.CryptoID.Poly hiding (decrypt, encrypt)
+
+import Data.UUID.Cryptographic
+import Data.UUID.Types
+import Web.PathPieces
+
+
+instance PathPiece UUID where
+  fromPathPiece = fromString . unpack
+  toPathPiece = pack . toString
+
+decKeysBinary [ ''SubmissionId
+              , ''CourseId
+              ]
+
+decTypeAliases [ "Submission"
+               , "Course"
+               ]

src/CryptoID/TH.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module CryptoID.TH where
+
+import ClassyPrelude
+
+import Language.Haskell.TH
+
+import Data.CryptoID (CryptoID)
+import Data.UUID.Types (UUID)
+import Data.Binary (Binary(..))
+
+import Database.Persist.Sql (toSqlKey, fromSqlKey)
+
+
+decTypeAliases :: [String] -> Q [Dec]
+decTypeAliases = return . concatMap decTypeAliases'
+  where
+    decTypeAliases' :: String -> [Dec]
+    decTypeAliases' n
+      = [ TySynD cryptoIDn [] $ ConT ''CryptoID `AppT` LitT (StrTyLit n)
+        , TySynD cryptoUUIDn [] $ ConT cryptoIDn `AppT` ConT ''UUID
+        ]
+      where
+        cryptoIDn = mkName $ "CryptoID" ++ n
+        cryptoUUIDn = mkName $ "CryptoUUID" ++ 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)
+          |]

src/Foundation.hs

@@ -50,6 +50,7 @@ data UniWorX = UniWorX
     , appConnPool    :: ConnectionPool -- ^ Database connection pool.
     , appHttpManager :: Manager
     , appLogger      :: Logger
+    , appCryptoIDKey :: CryptoIDKey
     }
 
 data MenuItem = MenuItem
@@ -177,6 +178,7 @@ instance Yesod UniWorX where
     isAuthorized (TermEditExistR _)     _ = return Authorized    
     isAuthorized CourseEditR            _ = return Authorized
     isAuthorized (CourseEditExistR _ _) _ = return Authorized
+    isAuthorized (CourseEditExistIDR _) _ = return Authorized    
     
     
 

src/Handler/Course.hs

@@ -19,6 +19,8 @@ import Yesod.Form.Bootstrap3
 import Colonnade
 import Yesod.Colonnade
 
+import qualified Data.UUID.Cryptographic as UUID
+
 
 getCourseListR :: Handler TypedContent
 getCourseListR = redirect TermShowR  
@@ -77,6 +79,12 @@ getCourseEditExistR tid csh = do
   course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh
   courseEditHandler course
 
+getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
+getCourseEditExistIDR cID = do
+  cIDKey <- getsYesod appCryptoIDKey
+  courseID <- UUID.decrypt cIDKey cID
+  courseEditHandler =<< runDB (getEntity courseID)
+
      
 courseEditHandler :: Maybe (Entity Course) -> Handler Html
 courseEditHandler course = do

src/Handler/Utils/Zip/Rating.hs

@@ -34,12 +34,16 @@ import Data.Text.Encoding.Error (UnicodeException(..))
 import qualified Data.Text.Lazy.Encoding as Lazy.Text
 
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
+import qualified Data.ByteString.Lazy as Lazy.ByteString
 
 import Text.Read (readEither)
 
 import GHC.Generics (Generic)
 import Data.Typeable (Typeable)
 
+import Data.Binary (encode, decode)
+import qualified Data.CryptoID.Poly as Poly
+
 
 instance HasResolution prec => Pretty (Fixed prec) where
   pretty = pretty . show
@@ -48,7 +52,7 @@ instance HasResolution prec => Pretty (Fixed prec) where
 data Rating = Rating
   { ratingCourseName :: Text
   , ratingSheetName :: Text
-  , ratingSubmissionId :: SubmissionId
+  , ratingSubmissionId :: CryptoIDSubmission ByteString -- ^ 'SubmissionId'
   , ratingComment :: Maybe Text
   , ratingPoints :: Maybe Points
   } deriving (Read, Show, Eq, Generic, Typeable)
@@ -67,10 +71,12 @@ instance Exception RatingException
 
 
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
-getRating ratingSubmissionId = runMaybeT $ do
-  Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get ratingSubmissionId
+getRating submissionId = runMaybeT $ do
+  Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get submissionId
   Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
   Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
+  cIDKey <- getsYesod appCryptoIDKey
+  ratingSubmissionId <- Poly.encrypt cIDKey . Lazy.ByteString.toStrict $ encode submissionId
   return Rating{..}
 
 formatRating :: Rating -> Lazy.ByteString

src/Import/NoFoundation.hs

@@ -12,3 +12,5 @@ import Yesod.Core.Types      as Import (loggerSet)
 import Yesod.Default.Config2 as Import
 
 import Data.Fixed            as Import
+
+import CryptoID              as Import

src/Settings.hs

@@ -59,6 +59,7 @@ data AppSettings = AppSettings
     -- ^ Copyright text to appear in the footer of the page
     , appAnalytics              :: Maybe Text
     -- ^ Google Analytics code
+    , appCryptoIDKeyFile        :: FilePath
 
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
@@ -87,6 +88,7 @@ instance FromJSON AppSettings where
 
         appCopyright              <- o .:  "copyright"
         appAnalytics              <- o .:? "analytics"
+        appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
 
         appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= defaultDev
 

stack.yaml

@@ -10,4 +10,7 @@ extra-deps:
 - colonnade-1.1.1
 - yesod-colonnade-1.1.0
 - zip-stream-0.1.0.1
+- uuid-crypto-1.1.0
+- cryptoids-0.1.0
+- cryptoids-types-0.0.0
 resolver: lts-9.3