diff --git a/Foundation.hs b/Foundation.hs index 48b1da0..12e32a3 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -66,7 +66,7 @@ instance Yesod App where defaultLayout widget = do master <- getYesod mmsg <- getMessage - msu <- lookupSession "username" + msu <- lookupSession "userId" -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and diff --git a/Handler/Login.hs b/Handler/Login.hs index 33c7d1a..15b2384 100644 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -1,6 +1,7 @@ module Handler.Login where import Import +import Data.Text data Credentials = Credentials { credentialsName :: Text @@ -24,7 +25,7 @@ postLoginR = do Just user -> do case credentialsPasswd cred == userPassword (entityVal user) of True -> do - setSession "username" $ userName (entityVal user) + setSession "userId" $ pack $ show $ entityKey user setMessage $ [shamlet|
Successfully logged in|] redirect $ HomeR False -> do @@ -41,6 +42,6 @@ loginForm = renderDivs $ Credentials getLogoutR :: Handler Html getLogoutR = do - deleteSession "username" + deleteSession "userId" setMessage $ [shamlet|Succesfully logged out|] redirect $ HomeR diff --git a/Handler/Profile.hs b/Handler/Profile.hs index 83e8ad3..80168b8 100644 --- a/Handler/Profile.hs +++ b/Handler/Profile.hs @@ -3,8 +3,11 @@ module Handler.Profile where import Import getProfileR :: Text -> Handler Html -getProfileR username = do - msu <- lookupSession "username" - userMedia <- runDB $ selectList [MediumOwner ==. username] [Desc MediumTime] - defaultLayout $ do - $(widgetFile "profile") +getProfileR username = error "reworking logic" -- do +-- msu <- lookupSession "id" +-- case msu of +-- Just tempUserId -> do +-- userId <- Key $ PersistInt64 $ fromIntegral tempUserId +-- userMedia <- runDB $ selectList [MediumOwner ==. userId] [Desc MediumTime] +-- defaultLayout $ do +-- $(widgetFile "profile") diff --git a/Handler/Signup.hs b/Handler/Signup.hs index 491fcdb..ac9fb52 100644 --- a/Handler/Signup.hs +++ b/Handler/Signup.hs @@ -44,6 +44,7 @@ signupForm = renderDivs $ User <$> areq textField "Username" Nothing <*> areq emailField "Email" Nothing <*> areq passwordField "Password" Nothing + <*> pure [] validateLen :: Text -> Bool validateLen a = diff --git a/Handler/Upload.hs b/Handler/Upload.hs index cba2808..d37b357 100644 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -4,37 +4,44 @@ import Import as I import Data.Time import Data.Text import System.FilePath +import Database.Persist.Types data TempMedium = TempMedium { tempMediumTitle :: Text , tempMediumFile :: FileInfo , tempMediumTime :: UTCTime - , tempMediumOwner :: Text + , tempMediumOwner :: UserId , tempMediumDesc :: Textarea , tempMediumTags :: [Text] } getUploadR :: Handler Html getUploadR = do - msu <- lookupSession "username" + msu <- lookupSession "userId" case msu of - Just username -> do - (uploadWidget, enctype) <- generateFormPost (uploadForm username) + Just tempUserId -> do + userId <- lift $ getUserIdFromText tempUserId + (uploadWidget, enctype) <- generateFormPost (uploadForm userId) defaultLayout $ do $(widgetFile "upload") Nothing -> do setMessage $ [shamlet|You need to be logged in|] redirect $ LoginR +--getUserIdFromText :: Text -> UserId +getUserIdFromText tempUserId = + Key $ PersistInt64 $ fromIntegral $ read $ unpack tempUserId + postUploadR :: Handler Html postUploadR = do - msu <- lookupSession "username" + msu <- lookupSession "userId" case msu of - Just username -> do - ((result, uploadWidget), enctype) <- runFormPost (uploadForm username) + Just tempUserId -> do + userId <- lift $ getUserIdFromText tempUserId + ((result, uploadWidget), enctype) <- runFormPost (uploadForm userId) case result of FormSuccess temp -> do - path <- writeOnDrive username $ tempMediumFile temp + path <- writeOnDrive $ tempMediumFile temp medium <- return $ Medium (tempMediumTitle temp) path @@ -52,21 +59,26 @@ postUploadR = do setMessage $ [shamlet|You need to be logged in|] redirect $ LoginR -writeOnDrive :: Text -> FileInfo -> Handler FilePath -writeOnDrive username file = do +writeOnDrive :: FileInfo -> Handler FilePath +writeOnDrive file = do filename <- return $ fileName file path <- return $ "static" > (unpack filename) liftIO $ fileMove file path return path -uploadForm :: Text -> Form TempMedium -uploadForm username = renderDivs $ TempMedium +uploadForm :: UserId -> Form TempMedium +uploadForm userId = renderDivs $ TempMedium <$> areq textField "Title" Nothing <*> areq fileField "Select file" Nothing <*> lift (liftIO getCurrentTime) - <*> pure username + <*> pure userId <*> areq textareaField "Description" Nothing <*> areq tagField "Enter tags" Nothing +-- <*> areq (selectField albums) "Album" Nothing +-- where +-- albums :: Handler App App (OptionList AlbumId) +-- albums = do +-- runDB $ selectList [AlbumOwner ==. userId] [Desc AlbumTitle] tagField :: Field Handler [Text] tagField = Field diff --git a/config/models b/config/models index 3baed98..6011f3c 100644 --- a/config/models +++ b/config/models @@ -2,20 +2,25 @@ User name Text email Text password Text + albums [AlbumId] deriving Typeable Token token Text user User + deriving Album title Text - owner Text + owner [UserId] content [MediumId] + deriving Medium title Text path FilePath time UTCTime - owner Text + owner UserId description Textarea tags [Text] + album AlbumId + deriving -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 5409ec0..e5ab1dd 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -1,8 +1,8 @@