changing logic. not working.

This commit is contained in:
nek0 2014-08-13 22:30:48 +02:00
parent 3dc4bf631a
commit 6fd8865944
7 changed files with 47 additions and 25 deletions

View file

@ -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

View file

@ -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|<pre>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|<pre>Succesfully logged out|]
redirect $ HomeR

View file

@ -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")

View file

@ -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 =

View file

@ -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|<pre>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|<pre>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

View file

@ -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)

View file

@ -1,8 +1,8 @@
<nav>
<div id="top-nav">
<ul id="user-nav">
$maybe user <- msu
Logged in as #{fromJust msu}
$maybe userId <- msu
Logged in as #{userId}
<li>
<a href=@{LogoutR}>Logout
<li>