Commit d947e772 authored by Christopher League's avatar Christopher League
Browse files

User import, some additional user fields

parent 199a1ad8
......@@ -9,13 +9,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
module App.Outline
( OutlineId (TheOutline),
Outline,
outTitle,
outActivities,
outUnits,
outSubtitle,
getHomeR,
( getHomeR,
)
where
......@@ -25,92 +19,15 @@ import App.Page
import App.Post
import App.Prelude
import App.User
import App.YamlStore
import Control.Lens (makeLenses)
import Data.Aeson as Js
import qualified Data.Set as Set
import Data.Time.Calendar (Day)
import Data.Time.Format
import Data.Tuple.Extra
import GHC.Generics hiding (Meta)
data OutlineId = TheOutline
deriving (Eq, Ord, Show, Read)
instance Key OutlineId where
keyDir = "course"
keyToFileName TheOutline = "outline.yaml"
keyFromFileName "outline.yaml" = Just TheOutline
keyFromFileName _ = Nothing
outlineJsonOpts :: Js.Options
outlineJsonOpts =
Js.defaultOptions
{ omitNothingFields = True,
fieldLabelModifier = lowerFirst . drop 4
}
data Activity
= Notes
{ _outPage :: PageId,
_outReadBy :: Maybe Day
}
deriving (Show, Generic)
instance ToJSON Activity where
toJSON = genericToJSON outlineJsonOpts
instance FromJSON Activity where
parseJSON = genericParseJSON outlineJsonOpts
data Unit
= Unit
{ _outSubtitle :: Text,
_outActivities :: [Activity]
}
deriving (Show, Generic)
instance ToJSON Unit where
toJSON = genericToJSON outlineJsonOpts
instance FromJSON Unit where
parseJSON = withObject "Unit" \v ->
Unit
<$> v .: "subtitle"
<*> (v .:? "activities" .!= [])
data Outline
= Outline
{ _outTitle :: Text,
_outUnits :: [Unit]
}
deriving (Show, Generic)
makeLenses ''Unit
makeLenses ''Outline
instance ToJSON Outline where
toJSON = genericToJSON outlineJsonOpts
instance FromJSON Outline where
parseJSON = genericParseJSON outlineJsonOpts
instance YamlEntity OutlineId Outline
-- devOutline :: (MonadIO m, MonadThrow m) => m Outline
-- devOutline =
-- runReaderT (loadY TheOutline) (WorkDir "data")
formatDay :: Day -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
-- The home page should still have *some* information even when not logged in:
-- link to PDF syllabus,
essentialLinks :: Widget
essentialLinks = do
let syllabusId = AssetId "cs101s20.pdf"
......
......@@ -53,6 +53,15 @@ getProfileR = do
<tr>
<th>Student ID:
<td>#{user ^. userStudentId}
<tr>
<th>School:
<td>#{user ^. userSchool}
<tr>
<th>Major:
<td>#{user ^. userMajor}
<tr>
<th>Year:
<td>#{user ^. userYear}
<tr>
<th>Email address:
<td>
......
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
......@@ -25,14 +26,19 @@ module App.User
userLastName,
userFirstName,
userNickName,
userMajor,
userSchool,
userYear,
userAvatar,
userReadPosts,
createSampleUsers,
findUserByIdent,
markPostAsRead,
devImport,
)
where
import App.ByteStoreWorkDir (WorkDirT)
import App.Post
import App.Prelude
import App.StoreKeys
......@@ -54,6 +60,7 @@ import GHC.Generics
import Text.Blaze.Html (ToMarkup (..))
import Web.PathPieces
import Yesod.Auth.Email
import Prelude (error)
newtype UserId
= UnsafeUserId {userIdText :: Text}
......@@ -119,13 +126,28 @@ data User
_userStudentId :: Int,
_userPassword :: Maybe SaltedPass,
_userEmail :: Email,
_userSchool :: Text,
_userMajor :: Text,
_userYear :: Text,
_userVerify :: Maybe UserVerify,
_userReadPosts :: Set PostId
}
deriving (Show, Generic)
instance Default User where
def = User "" "" def (-1) Nothing "" Nothing mempty
def =
User
mempty -- userLastName
mempty -- userFirstName
def -- userNickName
(-1) -- userStudentId
def -- userPassword
mempty -- userEmail
mempty -- userSchool
mempty -- userMajor
mempty -- userYear
def -- userVerify
def -- userReadPosts
makeLenses ''User
......@@ -226,3 +248,37 @@ userAvatar user =
markPostAsRead :: PostId -> User -> User
markPostAsRead p =
userReadPosts %~ Set.insert p
userFromTSV :: Text -> UserEntity
userFromTSV txt =
case Text.split (== '\t') txt of
[sid_, last, first, email, uid, school, major, year] ->
case readMaybe sid_ of
Nothing -> error "Non-numeric student ID"
Just sid ->
( UnsafeUserId uid,
simpleUser last first sid email
& userSchool .~ school
& userMajor .~ major
& userYear .~ year
)
_ ->
error "Unexpected fields"
importUser :: (MonadResource m, MonadUnliftIO m, MonadThrow m) => UserEntity -> m ()
importUser (uid, user) =
runStoreRW @WorkDirT @FilePath "data" $
existsObj uid >>= \case
True ->
putStrLn $ "Already exists: " <> userIdText uid
False -> do
putStrLn $ "Creating: " <> userIdText uid
saveY uid user
devImport :: FilePath -> IO ()
devImport csvFile =
runResourceT $ runConduit $
sourceFile csvFile
.| decodeUtf8C
.| linesUnboundedC
.| mapM_C (userFromTSV >>> importUser)
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment