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