diff --git a/Application.hs b/Application.hs index ff3f29b..4d0b2a5 100755 --- a/Application.hs +++ b/Application.hs @@ -49,7 +49,7 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger), -- Don't forget to add new modules to your cabal file! import Handler.Home -- import Handler.Signup --- import Handler.Login +import Handler.Login -- import Handler.Activate -- import Handler.Reactivate import Handler.Profile diff --git a/Foundation.hs b/Foundation.hs index 9dc0ec4..9e5fc0e 100755 --- a/Foundation.hs +++ b/Foundation.hs @@ -163,7 +163,24 @@ instance Yesod App where -- urlRenderOverride _ _ = Nothing -- The page to be redirected to when authentication is required. - -- authRoute _ = Just $ AuthR LoginR + authRoute _ = Just $ AuthR LoginR + + isAuthorized AdminR _ = getAdminAuth + isAuthorized AdminProfilesR _ = getAdminAuth + isAuthorized (AdminProfileSettingsR _) _ = getAdminAuth + isAuthorized (AdminUserAlbumsR _) _ = getAdminAuth + isAuthorized (AdminUserMediaR _) _ = getAdminAuth + isAuthorized (AdminProfileDeleteR _) _ = getAdminAuth + isAuthorized AdminAlbumsR _ = getAdminAuth + isAuthorized (AdminAlbumSettingsR _) _ = getAdminAuth + isAuthorized (AdminAlbumMediaR _) _ = getAdminAuth + isAuthorized (AdminAlbumDeleteR _) _ = getAdminAuth + isAuthorized AdminMediaR _ = getAdminAuth + isAuthorized (AdminMediumSettingsR _) _ = getAdminAuth + isAuthorized (AdminMediumDeleteR _) _ = getAdminAuth + isAuthorized AdminCommentR _ = getAdminAuth + isAuthorized (AdminCommentDeleteR _) _ = getAdminAuth + isAuthorized _ _ = return Authorized -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -196,6 +213,20 @@ instance Yesod App where makeLogger = return . appLogger +getAdminAuth = do + musername <- maybeAuthId + case musername of + Nothing -> return AuthenticationRequired + Just un -> do + muser <- runDB $ getBy $ UniqueUser un + return $ case muser of + Just (Entity _ u) + | isAdmin u -> Authorized + | otherwise -> Unauthorized "You are not authorized" + Nothing -> AuthenticationRequired + +isAdmin = userAdmin + -- How to run database actions. instance YesodPersist App where type YesodPersistBackend App = SqlBackend @@ -240,6 +271,7 @@ instance RenderMessage App FormMessage where instance YesodHmacKeccak (HmacPersistDB App User Token) App where runHmacDB = runHmacPersistDB + rawLoginRoute = Just LoginRawR instance UserCredentials (Entity User) where userUserName = userName . entityVal diff --git a/Handler/Album.hs b/Handler/Album.hs index 2a9ed41..0dffefc 100755 --- a/Handler/Album.hs +++ b/Handler/Album.hs @@ -31,15 +31,14 @@ getAlbumR albumId = do let ownerId = albumOwner album owner <- runDB $ getJust ownerId let ownerName = userName owner - let ownerSlug = userSlug owner - msu <- lookupSession "userId" - presence <- case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - return $ (userId == ownerId) || (userId `elem` albumShares album) + ownerSlug = userSlug owner + musername <- maybeAuthId + presence <- case musername of + Just username -> do + (Just (Entity uId _)) <- runDB $ getBy $ UniqueUser username + return $ (username == ownerName) || (uId `elem` albumShares album) Nothing -> return False --- media <- mapM (\a -> runDB $ getJust a) (albumContent album) media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime] defaultLayout $ do setTitle $ toHtml ("Eidolon :: Album " `T.append` albumTitle album) diff --git a/Handler/AlbumSettings.hs b/Handler/AlbumSettings.hs index e9c5460..57f1c81 100755 --- a/Handler/AlbumSettings.hs +++ b/Handler/AlbumSettings.hs @@ -28,25 +28,25 @@ getAlbumSettingsR albumId = do case tempAlbum of Just album -> do let ownerId = albumOwner album - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - let ownerPresence = userId == ownerId - let presence = userId `elem` (albumShares album) - case ownerPresence || presence of - True -> do - entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] - let users = map (\u -> (userName $ entityVal u, entityKey u)) entities - (albumSettingsWidget, enctype) <- generateFormPost $ - renderBootstrap3 BootstrapBasicForm $ - albumSettingsForm album albumId users - defaultLayout $ do - setTitle "Eidolon :: Album Settings" - $(widgetFile "albumSettings") - False -> do - setMessage "You must own this album to change its settings" - redirect $ AlbumR albumId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username + let ownerPresence = uId == ownerId + presence = uId `elem` (albumShares album) + if ownerPresence || presence + then do + entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] + let users = map (\u -> (userName $ entityVal u, entityKey u)) entities + (albumSettingsWidget, enctype) <- generateFormPost $ + renderBootstrap3 BootstrapBasicForm $ + albumSettingsForm album albumId users + defaultLayout $ do + setTitle "Eidolon :: Album Settings" + $(widgetFile "albumSettings") + else do + setMessage "You must own this album to change its settings" + redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to change settings" redirect $ AuthR LoginR @@ -62,63 +62,62 @@ postAlbumSettingsR albumId = do let ownerId = albumOwner album owner <- runDB $ getJust ownerId let ownerName = userName owner - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - let ownerPresence = userId == ownerId - let presence = userId `elem` albumShares album - if - ownerPresence || presence - then do - entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] - let users = map (\u -> (userName $ entityVal u, entityKey u)) entities - ((result, _), _) <- runFormPost $ - renderBootstrap3 BootstrapBasicForm $ - albumSettingsForm album albumId users - case result of - FormSuccess temp -> do - let newShares = L.sort $ albumShares temp - let oldShares = L.sort $ albumShares album - _ <- if - newShares /= oldShares - then do - link <- ($ AlbumR albumId) <$> getUrlRender - let rcptIds = L.nub $ newShares L.\\ oldShares - mapM (\uId -> do - -- update userAlbums - user <- runDB $ getJust uId - let oldAlbs = userAlbums user - let newAlbs = albumId : oldAlbs - _ <- runDB $ update uId [UserAlbums =. newAlbs] - -- send notification - let addr = userEmail user - sendMail addr "A new album was shared with you" $ - [shamlet| -

Hello #{userSlug user}! -

#{ownerName} was so kind to share his album #{albumTitle album} with you. -

You can find it - - here - . - |] - ) rcptIds - else do - return [()] - -- nothing to do here - _ <- runDB $ update albumId - [ AlbumTitle =. albumTitle temp - , AlbumShares =. newShares - , AlbumSamplePic =. albumSamplePic temp - ] - setMessage "Album settings changed succesfully" - redirect $ AlbumR albumId - _ -> do - setMessage "There was an error while changing the settings" - redirect $ AlbumSettingsR albumId - else do - setMessage "You must own this album to change its settings" - redirect $ AlbumR albumId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username + let ownerPresence = uId == ownerId + presence = uId `elem` albumShares album + if ownerPresence || presence + then do + entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] + let users = map (\u -> (userName $ entityVal u, entityKey u)) entities + ((result, _), _) <- runFormPost $ + renderBootstrap3 BootstrapBasicForm $ + albumSettingsForm album albumId users + case result of + FormSuccess temp -> do + let newShares = L.sort $ albumShares temp + let oldShares = L.sort $ albumShares album + _ <- if + newShares /= oldShares + then do + link <- ($ AlbumR albumId) <$> getUrlRender + let rcptIds = L.nub $ newShares L.\\ oldShares + mapM (\id -> do + -- update userAlbums + user <- runDB $ getJust id + let oldAlbs = userAlbums user + newAlbs = albumId : oldAlbs + _ <- runDB $ update id [UserAlbums =. newAlbs] + -- send notification + let addr = userEmail user + sendMail addr "A new album was shared with you" $ + [shamlet| +

Hello #{userSlug user}! +

#{ownerName} was so kind to share his album #{albumTitle album} with you. +

You can find it + + here + . + |] + ) rcptIds + else do + return [()] + -- nothing to do here + _ <- runDB $ update albumId + [ AlbumTitle =. albumTitle temp + , AlbumShares =. newShares + , AlbumSamplePic =. albumSamplePic temp + ] + setMessage "Album settings changed succesfully" + redirect $ AlbumR albumId + _ -> do + setMessage "There was an error while changing the settings" + redirect $ AlbumSettingsR albumId + else do + setMessage "You must own this album to change its settings" + redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to change settings" redirect $ AuthR LoginR @@ -145,19 +144,18 @@ getAlbumDeleteR albumId = do case tempAlbum of Just album -> do let ownerId = albumOwner album - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - if - userId == ownerId - then do - defaultLayout $ do - setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album)) - $(widgetFile "albumDelete") - else do - setMessage "You must own this album to delete it" - redirect $ AlbumR albumId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username + if uId == ownerId + then do + defaultLayout $ do + setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album)) + $(widgetFile "albumDelete") + else do + setMessage "You must own this album to delete it" + redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to delete albums" redirect $ AuthR LoginR @@ -172,52 +170,51 @@ postAlbumDeleteR albumId = do Just album -> do let ownerId = albumOwner album owner <- runDB $ getJust ownerId - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - if - userId == ownerId - then do - confirm <- lookupPostParam "confirm" - case confirm of - Just "confirm" -> do - -- remove album reference from user - let albumList = userAlbums owner - let newAlbumList = removeItem albumId albumList - runDB $ update ownerId [UserAlbums =. newAlbumList] - -- delete album content and its comments - _ <- mapM (\a -> do - -- delete files - medium <- runDB $ getJust a - liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) - liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) - liftIO $ removeFile (normalise $ L.tail $ mediumPreview medium) - -- delete comments - commEnts <- runDB $ selectList [CommentOrigin ==. a] [] - _ <- mapM (\c -> do - children <- runDB $ selectList [CommentParent ==. (Just $ entityKey c)] [] - _ <- mapM (\child -> do - -- delete comment children from elasticsearch and db - runDB $ delete $ entityKey child - ) children - -- delete comment from elasticsearch - runDB $ delete $ entityKey c) commEnts - runDB $ delete a - ) (albumContent album) - -- delete album - runDB $ delete albumId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username + if uId == ownerId + then do + confirm <- lookupPostParam "confirm" + case confirm of + Just "confirm" -> do + -- remove album reference from user + let albumList = userAlbums owner + let newAlbumList = removeItem albumId albumList + runDB $ update ownerId [UserAlbums =. newAlbumList] + -- delete album content and its comments + _ <- mapM (\a -> do -- delete files - liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey userId) T.unpack (extractKey albumId) - -- outro - setMessage "Album deleted succesfully" - redirect HomeR - _ -> do - setMessage "You must confirm the deletion" - redirect $ AlbumSettingsR albumId - else do - setMessage "You must own this album to delete it" - redirect $ AlbumR albumId + medium <- runDB $ getJust a + liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) + liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) + liftIO $ removeFile (normalise $ L.tail $ mediumPreview medium) + -- delete comments + commEnts <- runDB $ selectList [CommentOrigin ==. a] [] + _ <- mapM (\c -> do + children <- runDB $ selectList [CommentParent ==. (Just $ entityKey c)] [] + _ <- mapM (\child -> do + -- delete comment children from elasticsearch and db + runDB $ delete $ entityKey child + ) children + -- delete comment from elasticsearch + runDB $ delete $ entityKey c) commEnts + runDB $ delete a + ) (albumContent album) + -- delete album + runDB $ delete albumId + -- delete files + liftIO $ removeDirectoryRecursive $ "static" "data" T.unpack (extractKey uId) T.unpack (extractKey albumId) + -- outro + setMessage "Album deleted succesfully" + redirect HomeR + _ -> do + setMessage "You must confirm the deletion" + redirect $ AlbumSettingsR albumId + else do + setMessage "You must own this album to delete it" + redirect $ AlbumR albumId Nothing -> do setMessage "You must be logged in to delete albums" redirect $ AuthR LoginR diff --git a/Handler/Commons.hs b/Handler/Commons.hs index 39c313d..ef2d1ac 100755 --- a/Handler/Commons.hs +++ b/Handler/Commons.hs @@ -37,13 +37,12 @@ import Graphics.Text.TrueType import Debug.Trace -loginIsAdmin :: IsString t => Handler (Either (t, Route App) ()) +loginIsAdmin :: IsString t => Handler (Either (t, Route App) ()) loginIsAdmin = do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - user <- runDB $ getJust userId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username if userAdmin user then @@ -58,10 +57,10 @@ profileCheck userId = do tempUser <- runDB $ get userId case tempUser of Just user -> do - msu <- lookupSession "userId" - case msu of - Just tempLoginId -> do - let loginId = getUserIdFromText tempLoginId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity loginId _)) <- runDB $ getBy $ UniqueUser username if loginId == userId then @@ -79,13 +78,13 @@ mediumCheck mediumId = do case tempMedium of Just medium -> do let ownerId = mediumOwner medium - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username album <- runDB $ getJust $ mediumAlbum medium let presence = userId == ownerId - let albumOwnerPresence = userId == albumOwner album + albumOwnerPresence = userId == albumOwner album if presence || albumOwnerPresence then @@ -313,7 +312,7 @@ writeOnDrive fil userId albumId spec = do album <- runDB $ getJust albumId let ac = albumContent album [PersistInt64 int] <- case spec of - NewFile -> + NewFile -> if L.null ac then return [PersistInt64 1] else return $ keyToValues $ maximum $ ac Replace mId -> do medium <- runDB $ getJust mId diff --git a/Handler/Login.hs b/Handler/Login.hs index d7203c3..4e3e847 100755 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -34,8 +34,67 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Aeson.Types -getLoginR :: Handler Html -getLoginR = do +-- getLoginR :: Handler Html +-- getLoginR = do +-- master <- getYesod +-- let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master) +-- (loginRawWidget, _) <- generateFormPost $ +-- renderBootstrap3 BootstrapBasicForm loginForm +-- defaultLayout $ do +-- setTitle "Eidolon :: Login" +-- $(widgetFile "login") + + +-- postLoginR :: Handler RepJson +-- postLoginR = do +-- mUserName <- lookupPostParam "username" +-- mHexToken <- lookupPostParam "token" +-- mHexResponse <- lookupPostParam "response" +-- case (mUserName, mHexToken, mHexResponse) of +-- (Just userName, Nothing, Nothing) -> do +-- tempUser <- runDB $ getBy $ UniqueUser userName +-- case tempUser of +-- Just (Entity userId user) -> do +-- let salt = userSalt user +-- token <- liftIO makeRandomToken +-- runDB $ insert_ $ Token (encodeUtf8 token) "login" userName +-- returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)] +-- Nothing -> +-- returnJsonError ("No such user" :: T.Text) +-- (Nothing, Just hexToken, Just hexResponse) -> do +-- response <- do +-- let tempToken = fromHex' $ T.unpack hexToken +-- savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] +-- case savedToken of +-- Just (Entity tokenId token) -> do +-- let savedUserName = tokenUsername token +-- mqueriedUser <- runDB $ getBy $ UniqueUser savedUserName +-- let queriedUser = entityVal $ fromJust mqueriedUser +-- salted = userSalted queriedUser +-- hexSalted = toHex salted +-- expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted) +-- if encodeUtf8 hexResponse == expected +-- then do +-- -- Success!! +-- runDB $ delete tokenId +-- return $ Right $ (entityKey $ fromJust mqueriedUser) +-- else +-- return $ Left ("Wrong password" :: T.Text) +-- Nothing -> +-- return $ Left "Invalid token" +-- case response of +-- Left msg -> +-- returnJsonError msg +-- Right userId -> do +-- setSession "userId" $ extractKey userId +-- setMessage "Succesfully logged in" +-- welcomeLink <- ($ProfileR userId) <$> getUrlRender +-- returnJson ["welcome" .= welcomeLink] +-- _ -> +-- returnJsonError ("Protocol error" :: T.Text) + +getLoginRawR :: Handler Html +getLoginRawR = do master <- getYesod let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master) (loginRawWidget, _) <- generateFormPost $ @@ -44,55 +103,6 @@ getLoginR = do setTitle "Eidolon :: Login" $(widgetFile "login") - -postLoginR :: Handler RepJson -postLoginR = do - mUserName <- lookupPostParam "username" - mHexToken <- lookupPostParam "token" - mHexResponse <- lookupPostParam "response" - case (mUserName, mHexToken, mHexResponse) of - (Just userName, Nothing, Nothing) -> do - tempUser <- runDB $ getBy $ UniqueUser userName - case tempUser of - Just (Entity userId user) -> do - let salt = userSalt user - token <- liftIO makeRandomToken - runDB $ insert_ $ Token (encodeUtf8 token) "login" userName - returnJson ["salt" .= toHex salt, "token" .= toHex (encodeUtf8 token)] - Nothing -> - returnJsonError ("No such user" :: T.Text) - (Nothing, Just hexToken, Just hexResponse) -> do - response <- do - let tempToken = fromHex' $ T.unpack hexToken - savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] [] - case savedToken of - Just (Entity tokenId token) -> do - let savedUserName = tokenUsername token - mqueriedUser <- runDB $ getBy $ UniqueUser savedUserName - let queriedUser = entityVal $ fromJust mqueriedUser - salted = userSalted queriedUser - hexSalted = toHex salted - expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted) - if encodeUtf8 hexResponse == expected - then do - -- Success!! - runDB $ delete tokenId - return $ Right $ (entityKey $ fromJust mqueriedUser) - else - return $ Left ("Wrong password" :: T.Text) - Nothing -> - return $ Left "Invalid token" - case response of - Left msg -> - returnJsonError msg - Right userId -> do - setSession "userId" $ extractKey userId - setMessage "Succesfully logged in" - welcomeLink <- ($ProfileR userId) <$> getUrlRender - returnJson ["welcome" .= welcomeLink] - _ -> - returnJsonError ("Protocol error" :: T.Text) - postLoginRawR :: Handler Html postLoginRawR = do ((res, _), _) <- runFormPost $ @@ -105,18 +115,18 @@ postLoginRawR = do let testSalted = BC.unpack $ hmacKeccak (userSalt user) (encodeUtf8 $ credentialsPasswd cred) if fromHex' testSalted == userSalted user then do - setSession "userId" $ extractKey uId + setCreds False $ Creds "raw" (userName user) [] setMessage "Successfully logged in" redirect $ ProfileR uId else do setMessage "Wrong password" - redirect LoginR + redirect $ AuthR LoginR Nothing -> do setMessage "No such user" - redirect LoginR + redirect $ AuthR LoginR _ -> do setMessage "Login error" - redirect LoginR + redirect $ AuthR LoginR data Credentials = Credentials { credentialsName :: Text diff --git a/Handler/Medium.hs b/Handler/Medium.hs index fbc1c22..34b6b0c 100755 --- a/Handler/Medium.hs +++ b/Handler/Medium.hs @@ -36,10 +36,11 @@ getMediumR mediumId = do let ownerName = userName owner let albumId = mediumAlbum medium album <- runDB $ getJust albumId - msu <- lookupSession "userId" - userId <- case msu of - Just tempUserId -> - return $ Just $ getUserIdFromText tempUserId + musername <- maybeAuthId + userId <- case musername of + Just username -> do + (Just (Entity uId _)) <- runDB $ getBy $ UniqueUser username + return $ Just uId Nothing -> return Nothing let presence = userId == (Just ownerId) || userId == Just (albumOwner album) @@ -56,15 +57,20 @@ getMediumR mediumId = do [ CommentOrigin ==. mediumId , CommentParent !=. Nothing ] [ Asc CommentTime ] - let tr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) [] - pr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) [] - ir = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) [] + let tr = StaticR $ StaticRoute + (drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) [] + pr = StaticR $ StaticRoute + (drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) [] + ir = StaticR $ StaticRoute + (drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) [] lic = T.pack $ show (toEnum (mediumLicence medium) :: Licence) link = url (toEnum (mediumLicence medium) :: Licence) defaultLayout $ do setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium)) - rssLink (CommentFeedRssR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium - atomLink (CommentFeedAtomR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium + rssLink (CommentFeedRssR mediumId) $ + "Comment feed of medium " `T.append` mediumTitle medium + atomLink (CommentFeedAtomR mediumId) $ + "Comment feed of medium " `T.append` mediumTitle medium $(widgetFile "medium") Nothing -> do setMessage "This image does not exist" @@ -75,11 +81,10 @@ postMediumR mediumId = do tempMedium <- runDB $ get mediumId case tempMedium of Just medium -> do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - u <- runDB $ getJust userId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username let userSl = userSlug u ((res, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ @@ -95,7 +100,7 @@ postMediumR mediumId = do

Hello #{userSlug owner}

#{userSl} commented on your medium #{mediumTitle medium}:

#{commentContent temp} -

To follow the comment thread follow +

To follow the comment thread follow this link . @@ -126,10 +131,10 @@ getCommentReplyR commentId = do tempComment <- runDB $ get commentId case tempComment of Just comment -> do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username let mediumId = commentOrigin comment parAuth <- runDB $ get $ commentAuthor comment let parSlug = fromMaybe "" $ userSlug <$> parAuth @@ -151,13 +156,12 @@ postCommentReplyR commentId = do tempComment <- runDB $ get commentId case tempComment of Just comment -> do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - u <- runDB $ getJust userId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username let userSl = userSlug u - let mediumId = commentOrigin comment + mediumId = commentOrigin comment ((res, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ commentForm userId mediumId (Just commentId) @@ -208,10 +212,10 @@ getCommentDeleteR commentId = do tempComment <- runDB $ get commentId case tempComment of Just comment -> do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username if Just userId == Just (commentAuthor comment) then do @@ -233,10 +237,10 @@ postCommentDeleteR commentId = do tempComment <- runDB $ get commentId case tempComment of Just comment -> do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username if Just userId == Just (commentAuthor comment) then do diff --git a/Handler/MediumSettings.hs b/Handler/MediumSettings.hs index 50b7ab5..0af7706 100755 --- a/Handler/MediumSettings.hs +++ b/Handler/MediumSettings.hs @@ -119,20 +119,6 @@ postMediumDeleteR mediumId = do confirm <- lookupPostParam "confirm" case confirm of Just "confirm" -> do - -- -- delete comments - -- commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] - -- _ <- mapM (runDB . delete . entityKey) commEnts - -- -- delete references first - -- let albumId = mediumAlbum medium - -- album <- runDB $ getJust albumId - -- let mediaList = albumContent album - -- let newMediaList = removeItem mediumId mediaList - -- -- update reference List - -- runDB $ update albumId [AlbumContent =. newMediaList] - -- liftIO $ removeFile (normalise $ tail $ mediumPath medium) - -- liftIO $ removeFile (normalise $ tail $ mediumThumb medium) - -- liftIO $ removeFile (normalise $ tail $ mediumPreview medium) - -- runDB $ delete mediumId deleteMedium mediumId medium setMessage "Medium succesfully deleted" redirect HomeR diff --git a/Handler/NewAlbum.hs b/Handler/NewAlbum.hs index 840cc49..e34b4db 100755 --- a/Handler/NewAlbum.hs +++ b/Handler/NewAlbum.hs @@ -25,10 +25,10 @@ import System.FilePath getNewAlbumR :: Handler Html getNewAlbumR = do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - userId <- lift $ pure $ getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username (albumWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ albumForm userId @@ -41,10 +41,10 @@ getNewAlbumR = do postNewAlbumR :: Handler Html postNewAlbumR = do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ albumForm userId diff --git a/Handler/Profile.hs b/Handler/Profile.hs index fdf6021..c52f835 100755 --- a/Handler/Profile.hs +++ b/Handler/Profile.hs @@ -37,19 +37,19 @@ getProfileR ownerId = do then return $ Just alb else return Nothing ) allAlbs - let sharedAlbs = removeItem Nothing almostAlbs + let sharedAlbs = catMaybes almostAlbs recentMedia <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime] - msu <- lookupSession "userId" - presence <- case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - return (userId == ownerId) + -- msu <- lookupSession "userId" + musername <- maybeAuthId + presence <- case musername of + Just username -> + return (username == userName owner) Nothing -> return False defaultLayout $ do - setTitle $ toHtml ("Eidolon :: " `T.append` userSlug owner `T.append` "'s profile") - rssLink (UserFeedRssR ownerId) $ userSlug owner `T.append` "'s feed" - atomLink (UserFeedAtomR ownerId) $ userSlug owner `T.append` "'s feed" + setTitle $ toHtml ("Eidolon :: " `T.append` ownerSlug `T.append` "'s profile") + rssLink (UserFeedRssR ownerId) (ownerSlug `T.append` "'s feed") + atomLink (UserFeedAtomR ownerId) (ownerSlug `T.append` "'s feed") $(widgetFile "profile") Nothing -> do setMessage "This profile does not exist" diff --git a/Handler/Upload.hs b/Handler/Upload.hs index 2c98347..0720467 100755 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -26,7 +26,7 @@ import qualified Data.Text as T import Data.List as L import qualified System.FilePath as FP import System.Directory -import Text.Blaze.Internal +import Text.Blaze -- import Codec.ImageType -- import Codec.Picture as P -- import Codec.Picture.Metadata as PM @@ -43,15 +43,14 @@ getDirectUploadR albumId = do case tempAlbum of -- does the requested album exist Just album -> do let ownerId = albumOwner album - msu <- lookupSession "userId" - case msu of -- is anybody logged in - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of -- is anybody logged in + Just username -> do + (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username if userId == ownerId || userId `elem` albumShares album -- is the owner present or a user with whom the album is shared then do - user <- runDB $ getJust userId (dUploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId defaultLayout $ do setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album) @@ -72,14 +71,13 @@ postDirectUploadR albumId = do case tempAlbum of -- does the album exist Just album -> do let ownerId = albumOwner album - msu <- lookupSession "userId" - case msu of -- is anybody logged in - Just tempUserId -> do - let userId = getUserIdFromText tempUserId + musername <- maybeAuthId + case musername of -- is anybody logged in + Just username -> do + (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username if userId == ownerId || userId `elem` albumShares album -- is the logged in user the owner or is the album shared with him then do - user <- runDB $ getJust userId ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId case result of FormSuccess temp -> do @@ -97,15 +95,16 @@ postDirectUploadR albumId = do (fileBulkLicence temp) NewFile )indFils - let onlyErrNames = removeItem Nothing errNames + let onlyErrNames = catMaybes errNames if L.null onlyErrNames then do setMessage "All images succesfully uploaded" redirect $ AlbumR albumId else do - let justErrNames = map fromJust onlyErrNames - let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames + let msg = toMarkup $ + "File type not supported of: " `T.append` + (T.intercalate ", " onlyErrNames) setMessage msg redirect HomeR _ -> do @@ -135,7 +134,7 @@ dUploadForm userId user albumId = FileBulk where licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] defLicence = Just $ userDefaultLicence user - + data FileBulk = FileBulk { fileBulkPrefix :: T.Text @@ -150,11 +149,10 @@ data FileBulk = FileBulk getUploadR :: Handler Html getUploadR = do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - user <- runDB $ getJust userId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username let albums = userAlbums user if I.null albums @@ -196,11 +194,10 @@ bulkUploadForm userId user = (\a b c d e f g h -> FileBulk b c d e f g a h) postUploadR :: Handler Html postUploadR = do - msu <- lookupSession "userId" - case msu of - Just tempUserId -> do - let userId = getUserIdFromText tempUserId - user <- runDB $ getJust userId + musername <- maybeAuthId + case musername of + Just username -> do + (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user case result of FormSuccess temp -> do @@ -218,15 +215,16 @@ postUploadR = do (fileBulkLicence temp) NewFile )indFils - let onlyErrNames = removeItem Nothing errNames + let onlyErrNames = catMaybes errNames if L.null onlyErrNames then do setMessage "All images succesfully uploaded" redirect $ AlbumR $ fileBulkAlbum temp else do - let justErrNames = map fromJust onlyErrNames - let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames + let msg = toMarkup $ + "File type not supported of: " + `T.append` T.intercalate ", " onlyErrNames setMessage msg redirect $ AlbumR $ fileBulkAlbum temp _ -> do diff --git a/config/routes b/config/routes index 161ffa5..352d5d6 100755 --- a/config/routes +++ b/config/routes @@ -24,7 +24,7 @@ /page/#Int PageR GET -- /signup SignupR GET POST -- /login LoginR GET POST --- /loginraw LoginRawR POST +/loginraw LoginRawR GET POST -- /logout LogoutR GET -- /activate/#T.Text ActivateR GET POST -- /activateraw/#T.Text ActivateRawR POST diff --git a/eidolon.cabal b/eidolon.cabal index 78fe7d9..7639b3d 100755 --- a/eidolon.cabal +++ b/eidolon.cabal @@ -32,7 +32,7 @@ library Settings.Development Handler.Home -- Handler.Signup - -- Handler.Login + Handler.Login -- Handler.Activate -- Handler.Reactivate Handler.Profile @@ -141,7 +141,7 @@ library , http-client , yesod-form >= 1.4.7 , magic - , texmath < 0.9 + , texmath , yesod-auth , yesod-auth-hmac-keccak diff --git a/templates/login.hamlet b/templates/login.hamlet index d4c6025..33edb5d 100755 --- a/templates/login.hamlet +++ b/templates/login.hamlet @@ -12,19 +12,3 @@ $newline always your connection for leaks before proceeding.

^{loginRawWidget} - -
-
-
-