changing logic. not working.

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

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

Handler/Profile.hs

@@ -3,8 +3,11 @@ module Handler.Profile where
 import Import
 
 getProfileR :: Text -> Handler Html
-getProfileR username = do
+getProfileR username = error "reworking logic" -- do
-  msu <- lookupSession "username"
+--  msu <- lookupSession "id"
-  userMedia <- runDB $ selectList [MediumOwner ==. username] [Desc MediumTime]
+--  case msu of
-  defaultLayout $ do
+--    Just tempUserId -> do
-    $(widgetFile "profile")
+--      userId <- Key $ PersistInt64 $ fromIntegral tempUserId
+--      userMedia <- runDB $ selectList [MediumOwner ==. userId] [Desc MediumTime]
+--      defaultLayout $ do
+--        $(widgetFile "profile")

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 =

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
+    Just tempUserId -> do
-      (uploadWidget, enctype) <- generateFormPost (uploadForm username)
+      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
+    Just tempUserId -> do
-      ((result, uploadWidget), enctype) <- runFormPost (uploadForm username)
+      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 :: FileInfo -> Handler FilePath
-writeOnDrive username file = do
+writeOnDrive file = do
   filename <- return $ fileName file
   path <- return $ "static" </> (unpack filename)
   liftIO $ fileMove file path
   return path
 
-uploadForm :: Text -> Form TempMedium
+uploadForm :: UserId -> Form TempMedium
-uploadForm username = renderDivs $ 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

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)

templates/default-layout.hamlet

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