74 lines
2.2 KiB
Haskell
74 lines
2.2 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
|
|
{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module CryptoID
|
|
( module CryptoID
|
|
, module Data.CryptoID.Poly.ImplicitNamespace
|
|
, module Data.UUID.Cryptographic.ImplicitNamespace
|
|
, module System.FilePath.Cryptographic.ImplicitNamespace
|
|
) where
|
|
|
|
import CryptoID.TH
|
|
|
|
import ClassyPrelude hiding (fromString)
|
|
import Model
|
|
|
|
import Data.CryptoID.Poly.ImplicitNamespace
|
|
import Data.UUID.Cryptographic.ImplicitNamespace
|
|
import System.FilePath.Cryptographic.ImplicitNamespace
|
|
|
|
import Data.UUID.Types
|
|
import Web.PathPieces
|
|
|
|
import Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
instance PathPiece UUID where
|
|
fromPathPiece = fromString . unpack
|
|
toPathPiece = pack . toString
|
|
|
|
|
|
-- Generates CryptoUUID... Datatypes
|
|
decCryptoIDs [ ''SubmissionId
|
|
, ''CourseId
|
|
, ''SheetId
|
|
, ''FileId
|
|
, ''UserId
|
|
]
|
|
{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
|
|
|
|
|
|
|
|
newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
|
|
deriving (Show, Read, Eq)
|
|
|
|
pattern NewSubmission :: SubmissionMode
|
|
pattern NewSubmission = SubmissionMode Nothing
|
|
pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode
|
|
pattern ExistingSubmission cID = SubmissionMode (Just cID)
|
|
|
|
instance PathPiece SubmissionMode where
|
|
fromPathPiece "new" = Just $ SubmissionMode Nothing
|
|
fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s
|
|
|
|
toPathPiece (SubmissionMode Nothing) = "new"
|
|
toPathPiece (SubmissionMode (Just x)) = toPathPiece x
|
|
|
|
newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID)
|
|
deriving (Show, Read, Eq)
|
|
|
|
instance PathPiece (ZIPArchiveName objID) where
|
|
fromPathPiece (map CI.mk . unpack -> s)
|
|
| Just s' <- stripSuffix (map CI.mk ".zip") s = Just . ZIPArchiveName . CryptoID . CI.mk $ map CI.original s'
|
|
| otherwise = Nothing
|
|
|
|
toPathPiece (ZIPArchiveName CryptoID{..}) = pack (CI.foldedCase ciphertext) <> ".zip"
|