nek0/eidolon
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

more integration

Browse source
This commit is contained in:
nek0 2017-04-26 21:43:22 +02:00
parent be32449430
commit 224ebb9c9d
15 changed files with 335 additions and 326 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Application.hs
View file

@ -49,7 +49,7 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
import Handler.Home import Handler.Home
-- import Handler.Signup -- import Handler.Signup
-- import Handler.Login import Handler.Login
-- import Handler.Activate -- import Handler.Activate
-- import Handler.Reactivate -- import Handler.Reactivate
import Handler.Profile import Handler.Profile

34
Foundation.hs
View file

@ -163,7 +163,24 @@ instance Yesod App where
-- urlRenderOverride _ _ = Nothing -- urlRenderOverride _ _ = Nothing
-- The page to be redirected to when authentication is required. -- 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 -- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows -- and names them based on a hash of their content. This allows
@ -196,6 +213,20 @@ instance Yesod App where
makeLogger = return . appLogger 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. -- How to run database actions.
instance YesodPersist App where instance YesodPersist App where
type YesodPersistBackend App = SqlBackend type YesodPersistBackend App = SqlBackend
@ -240,6 +271,7 @@ instance RenderMessage App FormMessage where
instance YesodHmacKeccak (HmacPersistDB App User Token) App where instance YesodHmacKeccak (HmacPersistDB App User Token) App where
runHmacDB = runHmacPersistDB runHmacDB = runHmacPersistDB
rawLoginRoute = Just LoginRawR
instance UserCredentials (Entity User) where instance UserCredentials (Entity User) where
userUserName = userName . entityVal userUserName = userName . entityVal

13
Handler/Album.hs
View file

@ -31,15 +31,14 @@ getAlbumR albumId = do
let ownerId = albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
let ownerName = userName owner let ownerName = userName owner
let ownerSlug = userSlug owner ownerSlug = userSlug owner
msu <- lookupSession "userId" musername <- maybeAuthId
presence <- case msu of presence <- case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity uId _)) <- runDB $ getBy $ UniqueUser username
return $ (userId == ownerId) || (userId `elem` albumShares album) return $ (username == ownerName) || (uId `elem` albumShares album)
Nothing -> Nothing ->
return False return False
-- media <- mapM (\a -> runDB $ getJust a) (albumContent album)
media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime] media <- runDB $ selectList [MediumAlbum ==. albumId] [Desc MediumTime]
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Album " `T.append` albumTitle album) setTitle $ toHtml ("Eidolon :: Album " `T.append` albumTitle album)

265
Handler/AlbumSettings.hs
View file

@ -28,25 +28,25 @@ getAlbumSettingsR albumId = do
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
let ownerId = albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username
let ownerPresence = userId == ownerId let ownerPresence = uId == ownerId
let presence = userId `elem` (albumShares album) presence = uId `elem` (albumShares album)
case ownerPresence || presence of if ownerPresence || presence
True -> do then do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
let users = map (\u -> (userName $ entityVal u, entityKey u)) entities let users = map (\u -> (userName $ entityVal u, entityKey u)) entities
(albumSettingsWidget, enctype) <- generateFormPost $ (albumSettingsWidget, enctype) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm $
albumSettingsForm album albumId users albumSettingsForm album albumId users
defaultLayout $ do defaultLayout $ do
setTitle "Eidolon :: Album Settings" setTitle "Eidolon :: Album Settings"
$(widgetFile "albumSettings") $(widgetFile "albumSettings")
False -> do else do
setMessage "You must own this album to change its settings" setMessage "You must own this album to change its settings"
redirect $ AlbumR albumId redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to change settings" setMessage "You must be logged in to change settings"
redirect $ AuthR LoginR redirect $ AuthR LoginR
@ -62,63 +62,62 @@ postAlbumSettingsR albumId = do
let ownerId = albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
let ownerName = userName owner let ownerName = userName owner
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username
let ownerPresence = userId == ownerId let ownerPresence = uId == ownerId
let presence = userId `elem` albumShares album presence = uId `elem` albumShares album
if if ownerPresence || presence
ownerPresence || presence then do
then do entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] let users = map (\u -> (userName $ entityVal u, entityKey u)) entities
let users = map (\u -> (userName $ entityVal u, entityKey u)) entities ((result, _), _) <- runFormPost $
((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $
renderBootstrap3 BootstrapBasicForm $ albumSettingsForm album albumId users
albumSettingsForm album albumId users case result of
case result of FormSuccess temp -> do
FormSuccess temp -> do let newShares = L.sort $ albumShares temp
let newShares = L.sort $ albumShares temp let oldShares = L.sort $ albumShares album
let oldShares = L.sort $ albumShares album _ <- if
_ <- if newShares /= oldShares
newShares /= oldShares then do
then do link <- ($ AlbumR albumId) <$> getUrlRender
link <- ($ AlbumR albumId) <$> getUrlRender let rcptIds = L.nub $ newShares L.\\ oldShares
let rcptIds = L.nub $ newShares L.\\ oldShares mapM (\id -> do
mapM (\uId -> do -- update userAlbums
-- update userAlbums user <- runDB $ getJust id
user <- runDB $ getJust uId let oldAlbs = userAlbums user
let oldAlbs = userAlbums user newAlbs = albumId : oldAlbs
let newAlbs = albumId : oldAlbs _ <- runDB $ update id [UserAlbums =. newAlbs]
_ <- runDB $ update uId [UserAlbums =. newAlbs] -- send notification
-- send notification let addr = userEmail user
let addr = userEmail user sendMail addr "A new album was shared with you" $
sendMail addr "A new album was shared with you" $ [shamlet|
[shamlet| <h1>Hello #{userSlug user}!
<h1>Hello #{userSlug user}! <p>#{ownerName} was so kind to share his album #{albumTitle album} with you.
<p>#{ownerName} was so kind to share his album #{albumTitle album} with you. <p>You can find it
<p>You can find it <a href=#{link}>
<a href=#{link}> here
here .
. |]
|] ) rcptIds
) rcptIds else do
else do return [()]
return [()] -- nothing to do here
-- nothing to do here _ <- runDB $ update albumId
_ <- runDB $ update albumId [ AlbumTitle =. albumTitle temp
[ AlbumTitle =. albumTitle temp , AlbumShares =. newShares
, AlbumShares =. newShares , AlbumSamplePic =. albumSamplePic temp
, AlbumSamplePic =. albumSamplePic temp ]
] setMessage "Album settings changed succesfully"
setMessage "Album settings changed succesfully" redirect $ AlbumR albumId
redirect $ AlbumR albumId _ -> do
_ -> do setMessage "There was an error while changing the settings"
setMessage "There was an error while changing the settings" redirect $ AlbumSettingsR albumId
redirect $ AlbumSettingsR albumId else do
else do setMessage "You must own this album to change its settings"
setMessage "You must own this album to change its settings" redirect $ AlbumR albumId
redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to change settings" setMessage "You must be logged in to change settings"
redirect $ AuthR LoginR redirect $ AuthR LoginR
@ -145,19 +144,18 @@ getAlbumDeleteR albumId = do
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
let ownerId = albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username
if if uId == ownerId
userId == ownerId then do
then do defaultLayout $ do
defaultLayout $ do setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album))
setTitle $ toHtml ("Eidolon :: Delete album" `T.append` (albumTitle album)) $(widgetFile "albumDelete")
$(widgetFile "albumDelete") else do
else do setMessage "You must own this album to delete it"
setMessage "You must own this album to delete it" redirect $ AlbumR albumId
redirect $ AlbumR albumId
Nothing -> do Nothing -> do
setMessage "You must be logged in to delete albums" setMessage "You must be logged in to delete albums"
redirect $ AuthR LoginR redirect $ AuthR LoginR
@ -172,52 +170,51 @@ postAlbumDeleteR albumId = do
Just album -> do Just album -> do
let ownerId = albumOwner album let ownerId = albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity uId u)) <- runDB $ getBy $ UniqueUser username
if if uId == ownerId
userId == ownerId then do
then do confirm <- lookupPostParam "confirm"
confirm <- lookupPostParam "confirm" case confirm of
case confirm of Just "confirm" -> do
Just "confirm" -> do -- remove album reference from user
-- remove album reference from user let albumList = userAlbums owner
let albumList = userAlbums owner let newAlbumList = removeItem albumId albumList
let newAlbumList = removeItem albumId albumList runDB $ update ownerId [UserAlbums =. newAlbumList]
runDB $ update ownerId [UserAlbums =. newAlbumList] -- delete album content and its comments
-- delete album content and its comments _ <- mapM (\a -> do
_ <- 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
-- delete files -- delete files
liftIO $ removeDirectoryRecursive $ "static" </> "data" </> T.unpack (extractKey userId) </> T.unpack (extractKey albumId) medium <- runDB $ getJust a
-- outro liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
setMessage "Album deleted succesfully" liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
redirect HomeR liftIO $ removeFile (normalise $ L.tail $ mediumPreview medium)
_ -> do -- delete comments
setMessage "You must confirm the deletion" commEnts <- runDB $ selectList [CommentOrigin ==. a] []
redirect $ AlbumSettingsR albumId _ <- mapM (\c -> do
else do children <- runDB $ selectList [CommentParent ==. (Just $ entityKey c)] []
setMessage "You must own this album to delete it" _ <- mapM (\child -> do
redirect $ AlbumR albumId -- 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 Nothing -> do
setMessage "You must be logged in to delete albums" setMessage "You must be logged in to delete albums"
redirect $ AuthR LoginR redirect $ AuthR LoginR

31
Handler/Commons.hs
View file

@ -37,13 +37,12 @@ import Graphics.Text.TrueType
import Debug.Trace import Debug.Trace
loginIsAdmin :: IsString t => Handler (Either (t, Route App) ()) loginIsAdmin :: IsString t => Handler (Either (t, Route App) ())
loginIsAdmin = do loginIsAdmin = do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
user <- runDB $ getJust userId
if if
userAdmin user userAdmin user
then then
@ -58,10 +57,10 @@ profileCheck userId = do
tempUser <- runDB $ get userId tempUser <- runDB $ get userId
case tempUser of case tempUser of
Just user -> do Just user -> do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempLoginId -> do Just username -> do
let loginId = getUserIdFromText tempLoginId (Just (Entity loginId _)) <- runDB $ getBy $ UniqueUser username
if if
loginId == userId loginId == userId
then then
@ -79,13 +78,13 @@ mediumCheck mediumId = do
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
let ownerId = mediumOwner medium let ownerId = mediumOwner medium
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
album <- runDB $ getJust $ mediumAlbum medium album <- runDB $ getJust $ mediumAlbum medium
let presence = userId == ownerId let presence = userId == ownerId
let albumOwnerPresence = userId == albumOwner album albumOwnerPresence = userId == albumOwner album
if if
presence || albumOwnerPresence presence || albumOwnerPresence
then then
@ -313,7 +312,7 @@ writeOnDrive fil userId albumId spec = do
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
let ac = albumContent album let ac = albumContent album
[PersistInt64 int] <- case spec of [PersistInt64 int] <- case spec of
NewFile -> NewFile ->
if L.null ac then return [PersistInt64 1] else return $ keyToValues $ maximum $ ac if L.null ac then return [PersistInt64 1] else return $ keyToValues $ maximum $ ac
Replace mId -> do Replace mId -> do
medium <- runDB $ getJust mId medium <- runDB $ getJust mId

120
Handler/Login.hs
View file

@ -34,8 +34,67 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Char8 as BC
import Data.Aeson.Types import Data.Aeson.Types
getLoginR :: Handler Html -- getLoginR :: Handler Html
getLoginR = do -- 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 master <- getYesod
let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master) let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master)
(loginRawWidget, _) <- generateFormPost $ (loginRawWidget, _) <- generateFormPost $
@ -44,55 +103,6 @@ getLoginR = do
setTitle "Eidolon :: Login" setTitle "Eidolon :: Login"
$(widgetFile "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 :: Handler Html
postLoginRawR = do postLoginRawR = do
((res, _), _) <- runFormPost $ ((res, _), _) <- runFormPost $
@ -105,18 +115,18 @@ postLoginRawR = do
let testSalted = BC.unpack $ hmacKeccak (userSalt user) (encodeUtf8 $ credentialsPasswd cred) let testSalted = BC.unpack $ hmacKeccak (userSalt user) (encodeUtf8 $ credentialsPasswd cred)
if fromHex' testSalted == userSalted user if fromHex' testSalted == userSalted user
then do then do
setSession "userId" $ extractKey uId setCreds False $ Creds "raw" (userName user) []
setMessage "Successfully logged in" setMessage "Successfully logged in"
redirect $ ProfileR uId redirect $ ProfileR uId
else do else do
setMessage "Wrong password" setMessage "Wrong password"
redirect LoginR redirect $ AuthR LoginR
Nothing -> do Nothing -> do
setMessage "No such user" setMessage "No such user"
redirect LoginR redirect $ AuthR LoginR
_ -> do _ -> do
setMessage "Login error" setMessage "Login error"
redirect LoginR redirect $ AuthR LoginR
data Credentials = Credentials data Credentials = Credentials
{ credentialsName :: Text { credentialsName :: Text

70
Handler/Medium.hs
View file

@ -36,10 +36,11 @@ getMediumR mediumId = do
let ownerName = userName owner let ownerName = userName owner
let albumId = mediumAlbum medium let albumId = mediumAlbum medium
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
msu <- lookupSession "userId" musername <- maybeAuthId
userId <- case msu of userId <- case musername of
Just tempUserId -> Just username -> do
return $ Just $ getUserIdFromText tempUserId (Just (Entity uId _)) <- runDB $ getBy $ UniqueUser username
return $ Just uId
Nothing -> Nothing ->
return Nothing return Nothing
let presence = userId == (Just ownerId) || userId == Just (albumOwner album) let presence = userId == (Just ownerId) || userId == Just (albumOwner album)
@ -56,15 +57,20 @@ getMediumR mediumId = do
[ CommentOrigin ==. mediumId [ CommentOrigin ==. mediumId
, CommentParent !=. Nothing ] , CommentParent !=. Nothing ]
[ Asc CommentTime ] [ Asc CommentTime ]
let tr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) [] let tr = StaticR $ StaticRoute
pr = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) [] (drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) []
ir = StaticR $ StaticRoute (drop 2 $ map T.pack $ splitDirectories $ mediumPath 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) lic = T.pack $ show (toEnum (mediumLicence medium) :: Licence)
link = url (toEnum (mediumLicence medium) :: Licence) link = url (toEnum (mediumLicence medium) :: Licence)
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium)) setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
rssLink (CommentFeedRssR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium rssLink (CommentFeedRssR mediumId) $
atomLink (CommentFeedAtomR mediumId) $ "Comment feed of medium " `T.append` mediumTitle medium "Comment feed of medium " `T.append` mediumTitle medium
atomLink (CommentFeedAtomR mediumId) $
"Comment feed of medium " `T.append` mediumTitle medium
$(widgetFile "medium") $(widgetFile "medium")
Nothing -> do Nothing -> do
setMessage "This image does not exist" setMessage "This image does not exist"
@ -75,11 +81,10 @@ postMediumR mediumId = do
tempMedium <- runDB $ get mediumId tempMedium <- runDB $ get mediumId
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username
u <- runDB $ getJust userId
let userSl = userSlug u let userSl = userSlug u
((res, _), _) <- runFormPost $ ((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm $
@ -95,7 +100,7 @@ postMediumR mediumId = do
<h1>Hello #{userSlug owner} <h1>Hello #{userSlug owner}
<p>#{userSl} commented on your medium #{mediumTitle medium}: <p>#{userSl} commented on your medium #{mediumTitle medium}:
<p>#{commentContent temp} <p>#{commentContent temp}
<p>To follow the comment thread follow <p>To follow the comment thread follow
<a href=#{link}> <a href=#{link}>
this link this link
. .
@ -126,10 +131,10 @@ getCommentReplyR commentId = do
tempComment <- runDB $ get commentId tempComment <- runDB $ get commentId
case tempComment of case tempComment of
Just comment -> do Just comment -> do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
let mediumId = commentOrigin comment let mediumId = commentOrigin comment
parAuth <- runDB $ get $ commentAuthor comment parAuth <- runDB $ get $ commentAuthor comment
let parSlug = fromMaybe "" $ userSlug <$> parAuth let parSlug = fromMaybe "" $ userSlug <$> parAuth
@ -151,13 +156,12 @@ postCommentReplyR commentId = do
tempComment <- runDB $ get commentId tempComment <- runDB $ get commentId
case tempComment of case tempComment of
Just comment -> do Just comment -> do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username
u <- runDB $ getJust userId
let userSl = userSlug u let userSl = userSlug u
let mediumId = commentOrigin comment mediumId = commentOrigin comment
((res, _), _) <- runFormPost $ ((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm $
commentForm userId mediumId (Just commentId) commentForm userId mediumId (Just commentId)
@ -208,10 +212,10 @@ getCommentDeleteR commentId = do
tempComment <- runDB $ get commentId tempComment <- runDB $ get commentId
case tempComment of case tempComment of
Just comment -> do Just comment -> do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
if if
Just userId == Just (commentAuthor comment) Just userId == Just (commentAuthor comment)
then do then do
@ -233,10 +237,10 @@ postCommentDeleteR commentId = do
tempComment <- runDB $ get commentId tempComment <- runDB $ get commentId
case tempComment of case tempComment of
Just comment -> do Just comment -> do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
if if
Just userId == Just (commentAuthor comment) Just userId == Just (commentAuthor comment)
then do then do

14
Handler/MediumSettings.hs
View file

@ -119,20 +119,6 @@ postMediumDeleteR mediumId = do
confirm <- lookupPostParam "confirm" confirm <- lookupPostParam "confirm"
case confirm of case confirm of
Just "confirm" -> do 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 deleteMedium mediumId medium
setMessage "Medium succesfully deleted" setMessage "Medium succesfully deleted"
redirect HomeR redirect HomeR

16
Handler/NewAlbum.hs
View file

@ -25,10 +25,10 @@ import System.FilePath
getNewAlbumR :: Handler Html getNewAlbumR :: Handler Html
getNewAlbumR = do getNewAlbumR = do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
userId <- lift $ pure $ getUserIdFromText tempUserId (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
(albumWidget, enctype) <- generateFormPost $ (albumWidget, enctype) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm $
albumForm userId albumForm userId
@ -41,10 +41,10 @@ getNewAlbumR = do
postNewAlbumR :: Handler Html postNewAlbumR :: Handler Html
postNewAlbumR = do postNewAlbumR = do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
((result, _), _) <- runFormPost $ ((result, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $ renderBootstrap3 BootstrapBasicForm $
albumForm userId albumForm userId

18
Handler/Profile.hs
View file

@ -37,19 +37,19 @@ getProfileR ownerId = do
then return $ Just alb then return $ Just alb
else return Nothing else return Nothing
) allAlbs ) allAlbs
let sharedAlbs = removeItem Nothing almostAlbs let sharedAlbs = catMaybes almostAlbs
recentMedia <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime] recentMedia <- runDB $ selectList [MediumOwner ==. ownerId] [Desc MediumTime]
msu <- lookupSession "userId" -- msu <- lookupSession "userId"
presence <- case msu of musername <- maybeAuthId
Just tempUserId -> do presence <- case musername of
let userId = getUserIdFromText tempUserId Just username ->
return (userId == ownerId) return (username == userName owner)
Nothing -> Nothing ->
return False return False
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: " `T.append` userSlug owner `T.append` "'s profile") setTitle $ toHtml ("Eidolon :: " `T.append` ownerSlug `T.append` "'s profile")
rssLink (UserFeedRssR ownerId) $ userSlug owner `T.append` "'s feed" rssLink (UserFeedRssR ownerId) (ownerSlug `T.append` "'s feed")
atomLink (UserFeedAtomR ownerId) $ userSlug owner `T.append` "'s feed" atomLink (UserFeedAtomR ownerId) (ownerSlug `T.append` "'s feed")
$(widgetFile "profile") $(widgetFile "profile")
Nothing -> do Nothing -> do
setMessage "This profile does not exist" setMessage "This profile does not exist"

54
Handler/Upload.hs
View file

@ -26,7 +26,7 @@ import qualified Data.Text as T
import Data.List as L import Data.List as L
import qualified System.FilePath as FP import qualified System.FilePath as FP
import System.Directory import System.Directory
import Text.Blaze.Internal import Text.Blaze
-- import Codec.ImageType -- import Codec.ImageType
-- import Codec.Picture as P -- import Codec.Picture as P
-- import Codec.Picture.Metadata as PM -- import Codec.Picture.Metadata as PM
@ -43,15 +43,14 @@ getDirectUploadR albumId = do
case tempAlbum of -- does the requested album exist case tempAlbum of -- does the requested album exist
Just album -> do Just album -> do
let ownerId = albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of -- is anybody logged in case musername of -- is anybody logged in
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
if if
userId == ownerId || userId `elem` albumShares album userId == ownerId || userId `elem` albumShares album
-- is the owner present or a user with whom the album is shared -- is the owner present or a user with whom the album is shared
then do then do
user <- runDB $ getJust userId
(dUploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId (dUploadWidget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album) setTitle $ toHtml ("Eidolon :: Upload medium to " `T.append` albumTitle album)
@ -72,14 +71,13 @@ postDirectUploadR albumId = do
case tempAlbum of -- does the album exist case tempAlbum of -- does the album exist
Just album -> do Just album -> do
let ownerId = albumOwner album let ownerId = albumOwner album
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of -- is anybody logged in case musername of -- is anybody logged in
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
if userId == ownerId || userId `elem` albumShares album if userId == ownerId || userId `elem` albumShares album
-- is the logged in user the owner or is the album shared with him -- is the logged in user the owner or is the album shared with him
then do then do
user <- runDB $ getJust userId
((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ dUploadForm userId user albumId
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
@ -97,15 +95,16 @@ postDirectUploadR albumId = do
(fileBulkLicence temp) (fileBulkLicence temp)
NewFile NewFile
)indFils )indFils
let onlyErrNames = removeItem Nothing errNames let onlyErrNames = catMaybes errNames
if if
L.null onlyErrNames L.null onlyErrNames
then do then do
setMessage "All images succesfully uploaded" setMessage "All images succesfully uploaded"
redirect $ AlbumR albumId redirect $ AlbumR albumId
else do else do
let justErrNames = map fromJust onlyErrNames let msg = toMarkup $
let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames "File type not supported of: " `T.append`
(T.intercalate ", " onlyErrNames)
setMessage msg setMessage msg
redirect HomeR redirect HomeR
_ -> do _ -> do
@ -135,7 +134,7 @@ dUploadForm userId user albumId = FileBulk
where where
licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6] licences = optionsPairs $ I.map (\a -> (T.pack (show (toEnum a :: Licence)), a)) [-2..6]
defLicence = Just $ userDefaultLicence user defLicence = Just $ userDefaultLicence user
data FileBulk = FileBulk data FileBulk = FileBulk
{ fileBulkPrefix :: T.Text { fileBulkPrefix :: T.Text
@ -150,11 +149,10 @@ data FileBulk = FileBulk
getUploadR :: Handler Html getUploadR :: Handler Html
getUploadR = do getUploadR = do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
user <- runDB $ getJust userId
let albums = userAlbums user let albums = userAlbums user
if if
I.null albums 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 :: Handler Html
postUploadR = do postUploadR = do
msu <- lookupSession "userId" musername <- maybeAuthId
case msu of case musername of
Just tempUserId -> do Just username -> do
let userId = getUserIdFromText tempUserId (Just (Entity userId user)) <- runDB $ getBy $ UniqueUser username
user <- runDB $ getJust userId
((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user ((result, _), _) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ bulkUploadForm userId user
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
@ -218,15 +215,16 @@ postUploadR = do
(fileBulkLicence temp) (fileBulkLicence temp)
NewFile NewFile
)indFils )indFils
let onlyErrNames = removeItem Nothing errNames let onlyErrNames = catMaybes errNames
if if
L.null onlyErrNames L.null onlyErrNames
then do then do
setMessage "All images succesfully uploaded" setMessage "All images succesfully uploaded"
redirect $ AlbumR $ fileBulkAlbum temp redirect $ AlbumR $ fileBulkAlbum temp
else do else do
let justErrNames = map fromJust onlyErrNames let msg = toMarkup $
let msg = Content $ Text.Blaze.Internal.Text $ "File type not supported of: " `T.append` T.intercalate ", " justErrNames "File type not supported of: "
`T.append` T.intercalate ", " onlyErrNames
setMessage msg setMessage msg
redirect $ AlbumR $ fileBulkAlbum temp redirect $ AlbumR $ fileBulkAlbum temp
_ -> do _ -> do

2
config/routes
View file

@ -24,7 +24,7 @@
/page/#Int PageR GET /page/#Int PageR GET
-- /signup SignupR GET POST -- /signup SignupR GET POST
-- /login LoginR GET POST -- /login LoginR GET POST
-- /loginraw LoginRawR POST /loginraw LoginRawR GET POST
-- /logout LogoutR GET -- /logout LogoutR GET
-- /activate/#T.Text ActivateR GET POST -- /activate/#T.Text ActivateR GET POST
-- /activateraw/#T.Text ActivateRawR POST -- /activateraw/#T.Text ActivateRawR POST

4
eidolon.cabal
View file

@ -32,7 +32,7 @@ library
Settings.Development Settings.Development
Handler.Home Handler.Home
-- Handler.Signup -- Handler.Signup
-- Handler.Login Handler.Login
-- Handler.Activate -- Handler.Activate
-- Handler.Reactivate -- Handler.Reactivate
Handler.Profile Handler.Profile
@ -141,7 +141,7 @@ library
, http-client , http-client
, yesod-form >= 1.4.7 , yesod-form >= 1.4.7
, magic , magic
, texmath < 0.9 , texmath
, yesod-auth , yesod-auth
, yesod-auth-hmac-keccak , yesod-auth-hmac-keccak

16
templates/login.hamlet
View file

@ -12,19 +12,3 @@ $newline always
your connection for leaks before proceeding. your connection for leaks before proceeding.
<form method="post" action=@{LoginRawR}> <form method="post" action=@{LoginRawR}>
^{loginRawWidget} ^{loginRawWidget}
<form .js-hidden>
<div .form-group .required>
<label for="username">User:
<input .form-control #username type="text" required>
<div .form-group .required>
<label for="password">Password:
<input .form-control #password type="password" required>
<div .form-group .optional>
<button .btn .btn-default type="submit" #login>Login
<div #progress>
<a href=@{ReactivateR}>Forgot your Password?
<script src="/static/js/jquery.min.js" type="text/javascript">
<!--<script src="/static/js/jsSHA.js" type="text/javascript">-->
<script src="/static/js/purs_login.js" type="text/javascript">

2
templates/profile.hamlet
View file

@ -25,7 +25,7 @@ $if not (null sharedAlbs)
<div .subheader .item> <div .subheader .item>
<h1>Shared Albums <h1>Shared Albums
<p>Albums others have shared with this user <p>Albums others have shared with this user
$forall Just (Entity albumId album) <- sharedAlbs $forall (Entity albumId album) <- sharedAlbs
<div .item> <div .item>
<a href=@{AlbumR albumId}> <a href=@{AlbumR albumId}>
<figure> <figure>