diff --git a/Assignments.hs b/Assignments.hs new file mode 100644 --- /dev/null +++ b/Assignments.hs @@ -0,0 +1,219 @@ +module Assignments ( + Configuration(Configuration), + Assignment(Assignment), + UserIdentifier, + Year, + Submission(Submission), + Type(Homework , Exam , Project), + getConfiguration, + listSubmissions, + getSubmission, + listFiles, + createAssignment, + getSubmissionPath, + upload) where +import Data.Time.Clock +import Data.Time.Format +import System.Locale +import System.Directory +import Data.List +import qualified Data.Text as T + +root = "." + +confName = "conf" + +-- | A user identifier (not DB id) like a username or JMBAG +type UserIdentifier = String + +-- | Academic year shorthand (e.g. 2015 for 2015/16) +type Year = Integer + +-- | An assignment type +data Type = Homework | Exam | Project deriving Eq + +instance Show Type where + show Homework = "homework" + show Exam = "exam" + show Project = "project" + +-- | A an assignment configuration data structure +-- | Uses Data.Time.UTCTime +-- | If files is an empty list, ANY number of files are OK +data Configuration = Configuration { + published :: UTCTime, -- When to publish + deadline :: UTCTime, -- Submission deadline + lateDeadline :: UTCTime, -- Late submission deadline + files :: [String], -- File names to expect + minScore :: Double, -- Minimum achievable + maxScore :: Double, -- Maximum achievable + required :: Double -- Score req to pass +} + +instance Show Configuration where + show c = "published = " ++ show ( published c )++ "\n" ++ + "deadline = " ++ show ( deadline c ) ++ "\n" ++ + "lateDeadline = " ++ show ( lateDeadline c )++ "\n" ++ + "files = " ++ show ( files c) ++ "\n" ++ + "minScore = " ++ show ( minScore c) ++ "\n" ++ + "maxScore = " ++ show ( maxScore c) ++ "\n" ++ + "required = " ++ show ( required c) + +-- | An assignment descriptor +data Assignment = Assignment { + year :: Year, + aType :: Type, + number :: Int +} deriving (Show, Eq) + +data Submission = Submission { + assignment :: Assignment, + userId :: UserIdentifier, + submittedFiles :: [FilePath] +} deriving Show + +confFromString str = Configuration { + published = getUtc $ lv !! 0, + deadline = getUtc $ lv !! 1, + lateDeadline = getUtc $ lv !! 2, + files = read ((lv !! 3) !! 2) :: [String], + minScore = read ((lv !! 4) !! 2) :: Double, + maxScore = read ((lv !! 5) !! 2) :: Double, + required = read ((lv !! 6) !! 2) :: Double + } + where lv = map words $ lines str + getUtc s = read (intercalate " " $ drop 2 s) :: UTCTime + +getPathFromAssignment :: Assignment -> FilePath +getPathFromAssignment a = root ++ (show $ year a) ++ "/" ++ (show $ aType a) ++ "/" ++ (show $ number a) + +getConfiguration :: Assignment -> IO Configuration +getConfiguration asgn = do + fileExist <- doesFileExist $ (getPathFromAssignment asgn) ++ "/" ++ confName + if not fileExist + then error "Configuration file does not exist!" + else do + cnf <- readFile ((getPathFromAssignment asgn) ++ "/" ++ confName) + return $ confFromString cnf + +listSubmissions :: Assignment -> IO [UserIdentifier] +listSubmissions asgn = do + let path = (getPathFromAssignment asgn) + check <- doesDirectoryExist path + if check + then do + contents <- getDirectoryContents path + let submissions = filter (\x -> x /= confName && x /= "Assignment.pdf" && x /= "." && x /= "..") contents + return submissions + else + error "The assignment does not exist." + +getSubmission :: Assignment -> UserIdentifier -> IO Submission +getSubmission asgn user = do + let path = (getPathFromAssignment asgn) ++ "/" ++ user ++ "/" + check <- doesDirectoryExist path + if check + then do + contents <- getDirectoryContents path + let sFiles = filter (\x -> isInfixOf ".hs" x) contents + let sbm = Submission { assignment = asgn, userId = user, submittedFiles = sFiles } + return sbm + else + error "The user has not submitted this assignment" + +-- | Creates a new assignment from Assignment, configuration and PDF file +-- | The PDF file should be copied, moved or symlinked so that it is +-- | accessible from the assignment directory. +createAssignment :: Assignment -> Configuration -> FilePath -> IO () +createAssignment asg conf pdf = do + let path = getPathFromAssignment asg + createDirectoryIfMissing True path + copyFile pdf $ path ++ "/Assignment.pdf" + writeFile (path ++ "/" ++ confName) $ show conf + +-- Uses Text from Data.Text +-- T.pack :: String -> Text +-- T.unpack :: Text -> String +upload :: Submission -> T.Text -> String -> IO Submission +upload sub body name = do + let path = (getPathFromAssignment $ assignment sub) ++ "/" ++ (userId sub) + createDirectoryIfMissing True path + writeFile (path ++ "/" ++ name) (T.unpack body) + return $ sub {submittedFiles = nub(name:(submittedFiles sub))} + +listFiles :: Submission -> IO [FilePath] +listFiles s = do + return $ submittedFiles s + +getSubmissionPath :: Submission -> FilePath +getSubmissionPath s = getPathFromAssignment (assignment s) ++ "/" ++ (userId s) + +-- Test + +cnfg = Configuration { + published = read "2011-11-19 18:28:52.607875 UTC" :: UTCTime, + deadline = read "2011-11-19 18:28:52.607875 UTC" :: UTCTime, + lateDeadline = read "2011-11-19 18:28:52.607875 UTC" :: UTCTime, + files = ["exercises.hs", "homework.hs"], + minScore = 0.0, + maxScore = 8.0, + required = 4.0 +} + +asgn = Assignment { + year = 2015, + aType = Homework, + number = 1 +} + +subm = Submission { + assignment = asgn, + userId = "Taurius", + submittedFiles = [] +} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/Email.hs b/Email.hs new file mode 100644 --- /dev/null +++ b/Email.hs @@ -0,0 +1,183 @@ +module Email ( + Template, + Configuration, + compileTemplate, + getConfiguration, + sendMail) where + +import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import qualified Data.Map as M +import qualified Network.Mail.SMTP as Mail +import qualified Data.Text.Lazy as L +import qualified Network.Mail.Mime as Mime +import Data.Word +import Network.Socket.Internal +import Data.List + +-- | An alias for the template contents +type Template = T.Text + +-- | A user identifier (not DB id) like a username or JMBAG +type UserIdentifier = String + +data Role = Student Integer -- Academic Year shorthand (2015 for 2015/16) + | TA Integer Integer -- AY shorthand range (inclusive) + | Professor deriving (Eq, Ord, Show) + +-- | A user (the definition can be bigger) +data User = User { identifier :: UserIdentifier + , email :: String + , pwdHash :: String + , role :: Role + } deriving (Eq, Show) + +user1 = User {identifier = "Vienas", email = "medinismolis@gmx.com", pwdHash = "sgsvht", role = Professor}; +user2 = User {identifier = "Du", email = "medinismolis@gmx.com", pwdHash = "sgsvht", role = Student {}}; +user3 = User {identifier = "Trys", email = "medinismolis@gmx.com", pwdHash = "sgsvht", role = Student {}}; +user4 = User {identifier = "Keturi", email = "medinismolis@gmx.com", pwdHash = "sgsvht", role = TA {}}; +user5 = User {identifier = "Linas", email = "medinismolis@gmx.com", pwdHash = "sgsvht", role = TA {}}; +userList = [user1, user2, user3, user4, user5] + +-- | Configuration object +data Configuration = Configuration { + host :: String, + port :: PortNumber, + emailAddr :: String, + username :: String, + password :: String, + ident :: UserIdentifier +} deriving (Show) + +type Error = String + +-- | Parses an expression using traslateTags +compileTemplate :: Template -> M.Map String String -> Either Error L.Text +compileTemplate tmpl tmap = translateTags tmpl tmap + +-- | Get template text from a file path +getTemplate :: FilePath -> IO T.Text +getTemplate fp = do + contents <- readFile fp + return $ T.pack contents + +-- | Get configuration from a file path +getConfiguration :: FilePath -> IO Configuration +getConfiguration fp = do + contents <- readFile fp + return $ confFromStr contents + +confFromStr :: String -> Configuration +confFromStr str = Configuration { + host = drop 2 $ dropWhile (/= '=') (lns !! 0), + port = toEnum (read (drop 2 $ dropWhile (/= '=') (lns !! 1)) :: Int), + emailAddr = drop 2 $ dropWhile (/= '=') (lns !! 2), + username = drop 2 $ dropWhile (/= '=') (lns !! 3), + password = drop 2 $ dropWhile (/= '=') (lns !! 4), + ident = drop 2 $ dropWhile (/= '=') (lns !! 5) + } + where lns = lines str + +-- | Sends an e-mail with given text to list of users +-- | using given configuration. Throws appropriate error upon failure. +-- | Provide subject of the email as the last argument. +sendMail :: IO Configuration -> IO T.Text -> [User] -> String -> IO () +sendMail iocnfg iotxt list subj = do + txt <- iotxt + cnfg <- iocnfg + let mails = map (\x -> (T.pack $ email x, unwrapEither $ compileTemplate txt (createTemplateMap (ident cnfg) x), identifier x)) list + mapM_ (\(x,y,z) -> sendSingleMail x y z cnfg subj) mails -- sends all emails + --mapM_ (\(x,y,_) -> putStrLn $ (T.unpack x ++ " -> \n" ++ L.unpack y)) mails -- prints all emails + +-- | Prepares and sends email +sendSingleMail :: T.Text -> L.Text -> String -> Configuration -> String -> IO () +sendSingleMail addr txt recipName cnfg subj = do + let from = Mime.Address (Just $ T.pack $ ident cnfg) (T.pack $ emailAddr cnfg) + let to = [Mime.Address (Just $ T.pack recipName) (addr)] + let cc = [] + let bcc = [] + let subject = T.pack subj + let plainTextPart = Mail.plainTextPart txt + let parts = [plainTextPart] + let simpleMail = Mail.simpleMail from to cc bcc subject parts + Mail.sendMailWithLogin' (host cnfg) (port cnfg) (username cnfg) (password cnfg) simpleMail + + +-- | Available tags and booleans have their values stored in a +-- | Data.Map and are looked up when needed +createTemplateMap :: UserIdentifier -> User -> M.Map String String +createTemplateMap authorName user = M.fromList + [("<>", authorName) + ,("<>", identifier user) + ,("isStudent", isStudent user) + ,("isTA", isTA user) + ,("isProf", isProf user) + ,("True", "True") + ,("False", "False") + ] + + +-- | Traverses the text line by line and word by word to find tags +-- | and <> statements. +translateTags :: T.Text -> M.Map String String -> Either Error L.Text +translateTags txt tmap = Right ( L.pack $ translateTagsLines (lines $ T.unpack txt) []) + where translateTagsLines [] t = unlines t + translateTagsLines (x:xs) t = if isInfixOf "<>" x + then if checkCondition (head xs) tmap + then translateTagsLines (drop 2 $ dropWhile (\l -> not $ isInfixOf "<>" l) xs) (t ++ [translateTagsLines (drop 2 $ takeWhile (\l -> not $ isInfixOf "<>" l) xs) []]) + else translateTagsLines (drop 2 $ dropWhile (\l -> not $ isInfixOf "<>" l) xs) (t ++ [translateTagsLines (drop 1 $ dropWhile (\l -> not $ isInfixOf "<>" l) $ takeWhile (\l -> not $ isInfixOf "<>" l) xs) []]) + else translateTagsLines xs (t ++ [translateTagsWords (words x) []]) + translateTagsWords [] t = unwords t + translateTagsWords (x:xs) t = translateTagsWords xs (t ++ [checkWord x]) + checkWord word = if (length elems) > 0 + then (prefx ++ changedWord ++ sufx) + else word + where elems = M.elems (M.filterWithKey (\k _ -> isInfixOf k word) tmap) + changedWord = unwords elems + prefx = takeWhile (\l -> l /= '<') word + sufx = drop 2 $ dropWhile (\l -> l /= '>') word + + +data Expr = And Expr Expr | Or Expr Expr | Not Expr | Val Bool + deriving (Show,Read) + +eval' :: Expr -> Bool +eval' (Val x) = x +eval' (Not x) = not $ eval' x +eval' (Or x y) = eval' x || eval' y +eval' (And x y) = eval' x && eval' y + +addSpaces :: String -> String +addSpaces [] = "" +addSpaces ('(':xs) = "( " ++ addSpaces xs +addSpaces (')':xs) = " )" ++ addSpaces xs +addSpaces (x:xs) = [x] ++ addSpaces xs + +checkCondition :: String -> M.Map String String -> Bool +checkCondition x tmap = eval' (read (cc (words (addSpaces x)) "") :: Expr) + where cc [] exp = exp + cc (x:xs) exp = if M.member x tmap + then cc xs (exp ++ "Val " ++ unwrapMaybe(M.lookup x tmap)) + else cc xs (exp ++ x) + +isStudent :: User -> String +isStudent (User _ _ _ (Student _)) = "True" +isStudent (User _ _ _ _) = "False" + +isTA :: User -> String +isTA (User _ _ _ (TA _ _)) = "True" +isTA (User _ _ _ _) = "False" + +isProf :: User -> String +isProf (User _ _ _ Professor) = "True" +isProf (User _ _ _ _) = "False" + +unwrapMaybe :: Maybe String -> String +unwrapMaybe a = case a of + Just a -> a + Nothing -> "" + +unwrapEither :: Either a b -> b +unwrapEither a = case a of + Right x -> x + Left err -> error "err" diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016, AT&T + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of AT&T nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/PUH-Project.cabal b/PUH-Project.cabal new file mode 100644 --- /dev/null +++ b/PUH-Project.cabal @@ -0,0 +1,24 @@ +-- Initial PUH-Project.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: PUH-Project +version: 0.1.0.0 +synopsis: This is a package which includes Assignments, Email, User and Reviews modules for Programming in Haskell course. +-- description: +license: BSD3 +license-file: LICENSE +author: AT&T +maintainer: t.bulota@gmail.com +-- copyright: +category: Data +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: User, Role, Reviews, Email, Assignments + -- other-modules: + other-extensions: EmptyDataDecls, FlexibleContexts, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies + build-depends: base >=4.8 && <4.9, transformers >=0.4 && <0.5, persistent >=2.2 && <2.3, persistent-sqlite >=2.2 && <2.3, persistent-template >=2.1 && <2.2, pwstore-fast >=2.4 && <2.5, bytestring >=0.10 && <0.11, random >=1.1 && <1.2, directory >=1.2 && <1.3, text >=1.2 && <1.3, containers >=0.5 && <0.6, smtp-mail >=0.1 && <0.2, mime-mail >=0.4 && <0.5, network >=2.6 && <2.7, time >=1.5 && <1.6, old-locale >=1.0 && <1.1 + -- hs-source-dirs: + default-language: Haskell2010 diff --git a/Reviews.hs b/Reviews.hs new file mode 100644 --- /dev/null +++ b/Reviews.hs @@ -0,0 +1,205 @@ +module Reviews ( + ReviewAssignment(ReviewAssignment), + Review(Review), + Role(Student, Staff), + assignNReviews, + assignReviews, + storeAssigments, + assignedReviews, + assignmentsBy, + assignmentsFor, + saveReview, + reviews, + reviewsBy, + reviewsFor) where + +import System.Random +import Assignments +import Data.List +import Control.Monad +import System.Directory +import qualified Data.Text as T + +-- | A user’s role or authorization level as a reviewer +data Role = Student | Staff deriving (Eq, Ord, Show) + +-- | A review assignment representation +data ReviewAssignment = ReviewAssignment{ + reviewer :: UserIdentifier + , reviewee :: UserIdentifier + , role :: Role + , assignment :: Assignment +} deriving (Show) + +-- | A finished review +data Review = Review{ + reviewAssignment :: ReviewAssignment + , score :: Double + , text :: T.Text +} deriving Show + +assignmentsFile = "Assignments.txt" +reviewsFile = "Reviews.txt" + +-- | Takes an Assignment, a list of reviewer identifiers and a +-- | list of reviewee identifiers and assigns N reviewees for each +-- | reviewer. It makes sure that a user never reviews themselves. +-- | The reviewer is assigned the reviews with the provided role. +assignNReviews :: Assignment -> [UserIdentifier] -> [UserIdentifier] -> Int -> Role -> IO [ReviewAssignment] +assignNReviews asg reviewers reviewees n role = do + let reviewees' = take (n * (length reviewers)) (concat $ repeat reviewees) + let pairs = getP reviewers reviewees' n + let rez = map (\(x,y) -> (ReviewAssignment x y role asg)) pairs + return rez + +shuffle :: Eq a => [a] -> [a] -> IO ([a]) +shuffle [] rez = do + return rez +shuffle xs rez = do + el <- randomRIO (0, (length xs)-1) + let el' = xs !! el + let xs' = delete el' xs + shuffle xs' (el':rez) + +getP :: Eq a => [a] -> [a] -> Int -> [(a,a)] +getP x0 y0 n0 = getPairs x0 y0 n0 + where getPairs [] _ _ = [] + getPairs (x:xs) ys 0 = getPairs xs ys n0 + getPairs xs@(x:_) (y:ys) n + | x /= y = (x,y):(getPairs xs ys (n-1)) + | otherwise = getPairs xs (ys ++ [y]) n + +assignReviews :: Assignment -> [UserIdentifier] -> [UserIdentifier] -> Role -> IO [ReviewAssignment] +assignReviews asg reviewers reviewees role = do + reviewees' <- shuffle reviewees [] + let n = div (length reviewees) (length reviewers) + let reviewers' = concat $ replicate (n+1) reviewers + let rez = map (\(x,y) -> (ReviewAssignment x y role asg)) $ zip reviewers' reviewees' + return rez + + +-- | Stores a list of review assignments into a database or +-- | file system. +storeAssigments :: [ReviewAssignment] -> IO () +storeAssigments xs = do + let xs' = concatMap ((++"\n") . show) xs + writeFile assignmentsFile xs' + return () + +-- | Retrieves all ReviewAssignments for an Assignment from +-- | a database or file system. +assignedReviews :: Assignment -> IO [ReviewAssignment] +assignedReviews asg = do + fileExist <- doesFileExist assignmentsFile + if not fileExist + then return [] + else do + input <- readFile reviewsFile + return $ filter ((==asg) . assignment) $map (getReviewAsgFromStr) $ lines input + +-- Parse ReviewAssignment from string +getReviewAsgFromStr str = ReviewAssignment (read $ w !! 3) (read $ w !! 6) (getRole $ w !! 9) + (Assignment (read (w !! 15) :: Integer) + (getaType (w !! 18)) (read (w !! 21) :: Int)) + where w = words $ filter (\x -> x/=',' && x /= '}') str + +-- Returns Role from given String +getRole :: String -> Role +getRole "Student" = Student +getRole "Staff" = Staff +getRole _ = error "Can't parse role" + +-- Returns assignment type from given String +getaType :: String -> Type +getaType "homework" = Homework +getaType "exam" = Exam +getaType "project" = Project +getaType _ = error "Can't parse assignment type" + +-- | Retrieves all ReviewAssignments for an Assignment and +-- | a UserIdentifier, i.e. all the reviews for that assigment +-- | the user has to perform. +assignmentsBy :: Assignment -> UserIdentifier -> IO [ReviewAssignment] +assignmentsBy asg userId = do + filteredAsgn <- assignedReviews asg + let rez = filter ((==userId) . reviewer) filteredAsgn + return rez + +-- | Retrieves all ReviewAssignments for an Assignment and +-- | a UserIdentifier, i.e. all the reviews for that assignment +-- | where the user is a reviewee. +assignmentsFor :: Assignment -> UserIdentifier -> IO [ReviewAssignment] +assignmentsFor asg userId = do + filteredAsgn <- assignedReviews asg + let rez = filter ((==userId) . reviewee) filteredAsgn + return rez + +getReviewFromStr :: String -> IO Review +getReviewFromStr str = do + let con = getReAsg str " " + let rez = Review{ + reviewAssignment = getReviewAsgFromStr $ drop 27 $ fst con, + score = read (init ((words $ snd con) !! 3)) :: Double, + text = T.pack $ init $ init $ getText $ snd con + } + return rez + where getReAsg [] acc = (reverse acc, []) + getReAsg (a:b:xs) acc + | a == '}' && b == '}' = (reverse acc,xs) + | otherwise = getReAsg (b:xs) (a:acc) + getText [] = [] + getText (x:xs) + | x == '"' = xs + | otherwise = getText xs + + +-- | Completes a review assignment and stores the result in a +-- | file system or database. +saveReview :: Review -> IO () +saveReview r = do + fileExist <- doesFileExist reviewsFile + if not fileExist + then writeFile reviewsFile $ show r ++ "\n" + else do + input <- readFile reviewsFile + writeFile reviewsFile $ input ++ show r ++ "\n" + +-- | Loads all the completed review results for an assignment +reviews :: Assignment -> IO [Review] +reviews asg = do + fileExist <- doesFileExist reviewsFile + if not fileExist + then return [] + else do + input <- readFile reviewsFile + revs <- mapM getReviewFromStr $ lines input + return $ filter ((==asg) . assignment . reviewAssignment) revs + +-- | Loads all the completed review results for an assignment +-- | that were performed by a user. +reviewsBy :: Assignment -> UserIdentifier -> IO [Review] +reviewsBy asg user = do + revs <- reviews asg + return $ filter ((==user) . reviewer . reviewAssignment) revs + +-- | Loads all the completed review results for an assignment +-- | that were performed by a user. +reviewsFor :: Assignment -> UserIdentifier -> IO [Review] +reviewsFor asg user = do + revs <- reviews asg + return $ filter ((==user) . reviewee . reviewAssignment) revs + +asgn = Assignment 2016 Homework 1 + +rev = ReviewAssignment { + reviewer = "Luka124", + reviewee = "3984344", + role = Student, + assignment = asgn +} + +re = Review{ + reviewAssignment = rev, + score = 9.5, + text = T.pack "Good job" +} diff --git a/Role.hs b/Role.hs new file mode 100644 --- /dev/null +++ b/Role.hs @@ -0,0 +1,11 @@ +-- @role.hs +{-# LANGUAGE TemplateHaskell #-} +module Role where + +import Database.Persist.TH + +data Role = Student Integer -- Academic Year shorthand (2015 for 2015/16) + | TA Integer Integer -- AY shorthand range (inclusive) + | Professor deriving (Eq, Ord, Show, Read) + +derivePersistField "Role" diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/User.hs b/User.hs new file mode 100644 --- /dev/null +++ b/User.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module User ( + createUser, + updateUser, + deleteUser, + listUsers, + listUsersInRole, + getUser, + isRoleInYear, + UserIdentifier) where + +import Control.Monad.IO.Class (liftIO) +import Database.Persist +import Database.Persist.Sqlite +import Database.Persist.TH +import Role +import Crypto.PasswordStore +import qualified Data.ByteString.Char8 as B + +type UserIdentifier = String + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +User + identifier UserIdentifier + email String + pwdHash String + role Role + UUID identifier +|] + +instance Show User where + show u = "{identifier = " ++ show (userIdentifier u) ++ + ",email = " ++ show (userEmail u) ++ + ",role = " ++ show (userRole u) ++ "}" + +-- | Takes a user identifier, e-mail, password and role. +-- | Performs password hashing and stores the user into the +-- | database, returning a filled User. If creating it fails (e.g. +-- | the user identifier is already taken), throws an appropriate +-- | exception. +createUser :: UserIdentifier -> String -> String -> Role -> IO User +createUser id email pwd role = do + hash <- makePassword (B.pack pwd) 12 + runSqlite "UserDB.db" $ do + runMigration migrateAll + userId <- insert $ User id email (B.unpack hash) role + maybeUser <- get userId + case maybeUser of + Nothing -> error "Failed to add user" + Just user -> return user + +-- | Updates a given user. Identifies it by the UserIdentifier (or +-- | maybe database id field, if you added it) in the User and overwrites +-- | the DB entry with the values in the User structure. Throws an +-- | appropriate error if it cannot do so; e.g. the user does not exist. +updateUser :: User -> IO () +updateUser u = do + runSqlite "UserDB.db" $ do + runMigration migrateAll + maybeUser <- getBy $ UUID $ userIdentifier u + case maybeUser of + Nothing -> error "User not found" + Just (Entity userId user) -> replace userId u + return () + +-- | Deletes a user referenced by identifier. If no such user or the +-- | operation fails, an appropriate exception is thrown. +deleteUser :: UserIdentifier -> IO () +deleteUser id = do + runSqlite "UserDB.db" $ do + runMigration migrateAll + maybeEntity <- getBy $ UUID id + case maybeEntity of + Nothing -> error "User not found" + Just entity -> deleteBy $ UUID id + return () + +-- | Lists all the users +listUsers :: IO [User] +listUsers = runSqlite "UserDB.db" $ do + dbList <- selectList [] [] + let aa = Prelude.map entityVal dbList + return (aa) + +-- | Lists all users in a given role +listUsersInRole :: Role -> IO [User] +listUsersInRole role = do + runSqlite "UserDB.db" $ do + dbList <- selectList [UserRole ==. role] [] + let aa = Prelude.map entityVal dbList + return (aa) + +-- | Fetches a single user by identifier +getUser :: UserIdentifier -> IO User +getUser id = do + runSqlite "UserDB.db" $ do + runMigration migrateAll + maybeEntity <- getBy $ UUID id + case maybeEntity of + Nothing -> error "User not found" + Just entity -> return $ entityVal entity + +-- | Checks whether the user has a role of AT LEAST X in a given academic +-- | year. +isRoleInYear :: User -> Role -> Integer -> Bool +isRoleInYear ( User _ _ _ (Professor)) Professor _ = True +isRoleInYear ( User _ _ _ (Student y)) (Student _) y1 = + if (y1-1 == y || y1 == y) then True else False +isRoleInYear ( User _ _ _ (TA y0 y1)) (TA _ _) y = + if (y0 <= y && y1 >= y) then True else False +isRoleInYear _ _ _ = False