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!
import Handler.Home
-- import Handler.Signup
-- import Handler.Login
import Handler.Login
-- import Handler.Activate
-- import Handler.Reactivate
import Handler.Profile

34
Foundation.hs
View file

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

13
Handler/Album.hs
View file

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

265
Handler/AlbumSettings.hs
View file

@ -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|
<h1>Hello #{userSlug user}!
<p>#{ownerName} was so kind to share his album #{albumTitle album} with you.
<p>You can find it
<a href=#{link}>
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|
<h1>Hello #{userSlug user}!
<p>#{ownerName} was so kind to share his album #{albumTitle album} with you.
<p>You can find it
<a href=#{link}>
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

31
Handler/Commons.hs
View file

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

120
Handler/Login.hs
View file

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

70
Handler/Medium.hs
View file

@ -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
<h1>Hello #{userSlug owner}
<p>#{userSl} commented on your medium #{mediumTitle medium}:
<p>#{commentContent temp}
<p>To follow the comment thread follow
<p>To follow the comment thread follow
<a href=#{link}>
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

14
Handler/MediumSettings.hs
View file

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

16
Handler/NewAlbum.hs
View file

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

18
Handler/Profile.hs
View file

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

54
Handler/Upload.hs
View file

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

2
config/routes
View file

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

4
eidolon.cabal
View file

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

16
templates/login.hamlet
View file

@ -12,19 +12,3 @@ $newline always
your connection for leaks before proceeding.
<form method="post" action=@{LoginRawR}>
^{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>
<h1>Shared Albums
<p>Albums others have shared with this user
$forall Just (Entity albumId album) <- sharedAlbs
$forall (Entity albumId album) <- sharedAlbs
<div .item>
<a href=@{AlbumR albumId}>
<figure>