removed many compile time warnings

This commit is contained in:
nek0 2014-12-28 07:12:25 +01:00
parent 30deabbe35
commit 8305c43383
25 changed files with 59 additions and 107 deletions

View file

@ -7,18 +7,13 @@ module Application
) where ) where
import Import import Import
import Settings
import Yesod.Static import Yesod.Static
import Yesod.Default.Config2 import Yesod.Default.Config2
import Yesod.Default.Main
import Yesod.Default.Handlers import Yesod.Default.Handlers
import qualified Database.Persist
import Database.Persist.Sql (runMigration) import Database.Persist.Sql (runMigration)
import Network.HTTP.Client.Conduit (newManager) import Network.HTTP.Client.Conduit (newManager)
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad import Control.Monad
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr) import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize)
import Network.Wai.Logger (clockDateCacher)
import Data.Default (def) import Data.Default (def)
import Yesod.Core.Types (loggerSet) import Yesod.Core.Types (loggerSet)
@ -34,8 +29,7 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..), IPAddrSource (..),
OutputFormat (..), destination, OutputFormat (..), destination,
mkRequestLogger, outputFormat) mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, import System.Log.FastLogger (toLogStr)
toLogStr)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!

View file

@ -3,12 +3,8 @@ module Foundation where
import Prelude import Prelude
import Yesod import Yesod
import Yesod.Static import Yesod.Static
import Yesod.Default.Config2
import Yesod.Default.Util (addStaticContentExternal) import Yesod.Default.Util (addStaticContentExternal)
import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager)) import Network.HTTP.Client.Conduit (Manager, HasHttpManager (getHttpManager))
import qualified Settings
import Settings.Development (development)
import qualified Database.Persist
import Database.Persist.Sql -- (ConnectionPool, runSqlPool) import Database.Persist.Sql -- (ConnectionPool, runSqlPool)
import Settings.StaticFiles import Settings.StaticFiles
import Settings import Settings
@ -18,7 +14,6 @@ import Text.Hamlet (hamletFile)
import Yesod.Core.Types import Yesod.Core.Types
-- costom imports -- costom imports
import Data.Text import Data.Text
import Data.Maybe
import Helper import Helper
-- | The site argument for your application. This can be a good place to -- | The site argument for your application. This can be a good place to
@ -56,7 +51,7 @@ instance Yesod App where
approot = ApprootMaster $ appRoot . appSettings approot = ApprootMaster $ appRoot . appSettings
-- change maximum content length -- change maximum content length
maximumContentLength _ _ = Just $ 1024 ^ 5 maximumContentLength _ _ = Just $ 1024 ^ (5 :: Int)
-- Store session data on the client in encrypted cookies, -- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes -- default session idle timeout is 120 minutes

View file

@ -14,7 +14,7 @@ getActivateR token = do
Nothing -> do Nothing -> do
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
case mToken of case mToken of
Just (Entity uTokenId uToken) -> do Just (Entity _ uToken) -> do
user <- runDB $ getJust (fromJust $ tokenUser uToken) user <- runDB $ getJust (fromJust $ tokenUser uToken)
hexSalt <- return $ toHex $ userSalt user hexSalt <- return $ toHex $ userSalt user
defaultLayout $ do defaultLayout $ do
@ -23,11 +23,11 @@ getActivateR token = do
_ -> do _ -> do
setMessage "Invalid token!" setMessage "Invalid token!"
redirect $ HomeR redirect $ HomeR
Just (Entity activatorKey activator) -> do Just (Entity _ activator) -> do
uSalt <- return $ userSalt $ activatorUser activator uSalt <- return $ userSalt $ activatorUser activator
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] [] mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
case mToken of case mToken of
Just (Entity uTokenId uToken) -> do Just (Entity _ _) -> do
hexSalt <- return $ toHex uSalt hexSalt <- return $ toHex uSalt
defaultLayout $ do defaultLayout $ do
$(widgetFile "activate") $(widgetFile "activate")

View file

@ -70,10 +70,10 @@ postAdminAlbumSettingsR albumId = do
Just album -> do Just album -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
((res, adminAlbumSettingsWidget), enctype) <- runFormPost $ adminAlbumSettingsForm album albumId users ((res, _), _) <- runFormPost $ adminAlbumSettingsForm album albumId users
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
aId <- runDB $ update albumId _ <- runDB $ update albumId
[ AlbumTitle =. albumTitle temp [ AlbumTitle =. albumTitle temp
, AlbumShares =. albumShares temp , AlbumShares =. albumShares temp
, AlbumSamplePic =. albumSamplePic temp , AlbumSamplePic =. albumSamplePic temp
@ -117,14 +117,14 @@ getAdminAlbumDeleteR albumId = do
newAlbumList <- return $ removeItem albumId albumList newAlbumList <- return $ 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 -- delete files
medium <- runDB $ getJust a medium <- runDB $ getJust a
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] [] commEnts <- runDB $ selectList [CommentOrigin ==. a] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete album database entry -- delete album database entry
runDB $ delete a runDB $ delete a
) (albumContent album) ) (albumContent album)

View file

@ -28,10 +28,10 @@ getAdminCommentDeleteR commentId = do
Right _ -> do Right _ -> do
tempComment <- runDB $ get commentId tempComment <- runDB $ get commentId
case tempComment of case tempComment of
Just comment -> do Just _ -> do
-- delete comment children -- delete comment children
children <- runDB $ selectList [CommentParent ==. (Just commentId)] [] children <- runDB $ selectList [CommentParent ==. (Just commentId)] []
mapM (\ent -> runDB $ delete $ entityKey ent) children _ <- mapM (\ent -> runDB $ delete $ entityKey ent) children
-- delete comment itself -- delete comment itself
runDB $ delete commentId runDB $ delete commentId
setMessage "Comment deleted succesfully" setMessage "Comment deleted succesfully"

View file

@ -46,7 +46,7 @@ postAdminMediumSettingsR mediumId = do
tempMedium <- runDB $ get mediumId tempMedium <- runDB $ get mediumId
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
((res, adminMediumSetWidget), enctype) <- runFormPost $ adminMediumSetForm medium ((res, _), _) <- runFormPost $ adminMediumSetForm medium
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
runDB $ update mediumId runDB $ update mediumId
@ -94,7 +94,7 @@ getAdminMediumDeleteR mediumId = do
runDB $ update albumId [AlbumContent =. newMediaList] runDB $ update albumId [AlbumContent =. newMediaList]
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete medium -- delete medium
runDB $ delete mediumId runDB $ delete mediumId
-- delete files -- delete files

View file

@ -88,7 +88,7 @@ postAdminProfileSettingsR ownerId = do
tempOwner <- runDB $ get ownerId tempOwner <- runDB $ get ownerId
case tempOwner of case tempOwner of
Just owner -> do Just owner -> do
((result, adminProfileSetWidget), enctype) <- runFormPost $ adminProfileForm owner ((result, _), _) <- runFormPost $ adminProfileForm owner
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
runDB $ update ownerId runDB $ update ownerId
@ -129,13 +129,13 @@ getAdminProfileDeleteR ownerId = do
case tempOwner of case tempOwner of
Just owner -> do Just owner -> do
albumList <- return $ userAlbums owner albumList <- return $ userAlbums owner
mapM (\albumId -> do _ <- mapM (\albumId -> do
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
mediaList <- return $ albumContent album mediaList <- return $ albumContent album
mapM (\med -> do _ <- mapM (\med -> do
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. med] [] commEnts <- runDB $ selectList [CommentOrigin ==. med] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete media files -- delete media files
medium <- runDB $ getJust med medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)

View file

@ -12,8 +12,6 @@ getAlbumSettingsR albumId = do
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
@ -56,12 +54,12 @@ postAlbumSettingsR albumId = do
True -> do True -> do
entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName] entities <- runDB $ selectList [UserId !=. (albumOwner album)] [Desc UserName]
users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities users <- return $ map (\u -> (userName $ entityVal u, entityKey u)) entities
((result, albumSettingsWidget), enctype) <- runFormPost $ albumSettingsForm album albumId users ((result, _), _) <- runFormPost $ albumSettingsForm album albumId users
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
newShares <- return (L.sort $ albumShares temp) newShares <- return (L.sort $ albumShares temp)
oldShares <- return (L.sort $ albumShares album) oldShares <- return (L.sort $ albumShares album)
case newShares /= oldShares of _ <- case newShares /= oldShares of
True -> do True -> do
link <- ($ AlbumR albumId) <$> getUrlRender link <- ($ AlbumR albumId) <$> getUrlRender
rcptIds <- return $ L.nub $ newShares L.\\ oldShares rcptIds <- return $ L.nub $ newShares L.\\ oldShares
@ -81,7 +79,7 @@ postAlbumSettingsR albumId = do
False -> do False -> do
return [()] return [()]
-- nothing to do here -- nothing to do here
aId <- runDB $ update albumId _ <- runDB $ update albumId
[ AlbumTitle =. albumTitle temp [ AlbumTitle =. albumTitle temp
, AlbumShares =. newShares , AlbumShares =. newShares
, AlbumSamplePic =. albumSamplePic temp , AlbumSamplePic =. albumSamplePic temp
@ -122,8 +120,6 @@ getAlbumDeleteR albumId = do
case tempAlbum of case tempAlbum of
Just album -> do Just album -> do
ownerId <- return $ albumOwner album ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
@ -151,7 +147,6 @@ postAlbumDeleteR albumId = do
Just album -> do Just album -> do
ownerId <- return $ albumOwner album ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
@ -167,14 +162,14 @@ postAlbumDeleteR albumId = do
newAlbumList <- return $ removeItem albumId albumList newAlbumList <- return $ 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 -- delete files
medium <- runDB $ getJust a medium <- runDB $ getJust a
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. a] [] commEnts <- runDB $ selectList [CommentOrigin ==. a] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
runDB $ delete a runDB $ delete a
) (albumContent album) ) (albumContent album)
-- delete album -- delete album

View file

@ -44,7 +44,6 @@ mediumCheck mediumId = do
case tempMedium of case tempMedium of
Just medium -> do Just medium -> do
ownerId <- return $ mediumOwner medium ownerId <- return $ mediumOwner medium
owner <- runDB $ getJust ownerId
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do

View file

@ -2,13 +2,13 @@ module Handler.Login where
import Import hiding (returnJson) import Import hiding (returnJson)
import qualified Data.Text as T import qualified Data.Text as T
import Yesod hiding (returnJson)
import Crypto.HMAC import Crypto.HMAC
import Crypto.Hash.CryptoAPI (SHA1) import Crypto.Hash.CryptoAPI (SHA1)
import qualified Data.ByteString as B import Data.Text.Encoding (encodeUtf8)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Serialize (encode) import Data.Serialize (encode)
import Data.Maybe import Data.Maybe
import qualified Data.ByteString as B
import Data.Aeson.Types
data Credentials = Credentials data Credentials = Credentials
{ credentialsName :: Text { credentialsName :: Text
@ -37,7 +37,7 @@ postLoginR = do
Just (Entity userId user) -> do Just (Entity userId user) -> do
salt <- return $ userSalt user salt <- return $ userSalt user
token <- liftIO makeRandomToken token <- liftIO makeRandomToken
tokenId <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId) _ <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId)
returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)] returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)]
Nothing -> Nothing ->
returnJsonError ("No such user" :: T.Text) returnJsonError ("No such user" :: T.Text)
@ -85,10 +85,13 @@ getLogoutR = do
setMessage "Succesfully logged out" setMessage "Succesfully logged out"
redirect $ HomeR redirect $ HomeR
returnJson :: Monad m => [Pair] -> m RepJson
returnJson = return . repJson . object returnJson = return . repJson . object
returnJsonError :: (ToJSON a, Monad m) => a -> m RepJson
returnJsonError = returnJson . (:[]) . ("error" .=) returnJsonError = returnJson . (:[]) . ("error" .=)
hmacSHA1 :: B.ByteString -> B.ByteString -> B.ByteString
hmacSHA1 keyData msgData = hmacSHA1 keyData msgData =
let key = MacKey keyData let key = MacKey keyData
sha1 :: SHA1 sha1 :: SHA1

View file

@ -51,10 +51,10 @@ postMediumR mediumId = do
userId <- return $ Just $ getUserIdFromText tempUserId userId <- return $ Just $ getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId u <- runDB $ getJust $ fromJust userId
userSl <- return $ Just $ userSlug u userSl <- return $ Just $ userSlug u
((res, commentiwdget), enctype) <- runFormPost $ commentForm userId userSl mediumId Nothing ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId Nothing
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
cId <- runDB $ insert temp _ <- runDB $ insert temp
--send mail to medium owner --send mail to medium owner
owner <- runDB $ getJust $ mediumOwner medium owner <- runDB $ getJust $ mediumOwner medium
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
@ -124,10 +124,10 @@ postCommentReplyR commentId = do
u <- runDB $ getJust $ fromJust userId u <- runDB $ getJust $ fromJust userId
userSl <- return $ Just $ userSlug u userSl <- return $ Just $ userSlug u
mediumId <- return $ commentOrigin comment mediumId <- return $ commentOrigin comment
((res, commentWidget), enctype) <- runFormPost $ commentForm userId userSl mediumId (Just commentId) ((res, _), _) <- runFormPost $ commentForm userId userSl mediumId (Just commentId)
case res of case res of
FormSuccess temp -> do FormSuccess temp -> do
cId <- runDB $ insert temp _ <- runDB $ insert temp
--send mail to parent author --send mail to parent author
parent <- runDB $ getJust $ fromJust $ commentParent temp parent <- runDB $ getJust $ fromJust $ commentParent temp
parAuth <- runDB $ getJust $ fromJust $ commentAuthor parent parAuth <- runDB $ getJust $ fromJust $ commentAuthor parent
@ -209,7 +209,7 @@ postCommentDeleteR commentId = do
Just "confirm" -> do Just "confirm" -> do
-- delete comment children -- delete comment children
childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] [] childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] []
mapM (\ent -> runDB $ delete $ entityKey ent) childEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) childEnts
-- delete comment itself -- delete comment itself
runDB $ delete commentId runDB $ delete commentId
-- outro -- outro

View file

@ -24,10 +24,10 @@ postMediumSettingsR mediumId = do
checkRes <- mediumCheck mediumId checkRes <- mediumCheck mediumId
case checkRes of case checkRes of
Right medium -> do Right medium -> do
((result, mediumSettingsWidget), enctype) <- runFormPost $ mediumSettingsForm medium ((result, _), _) <- runFormPost $ mediumSettingsForm medium
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
mId <- runDB $ update mediumId _ <- runDB $ update mediumId
[ MediumTitle =. mediumTitle temp [ MediumTitle =. mediumTitle temp
, MediumDescription =. mediumDescription temp , MediumDescription =. mediumDescription temp
, MediumTags =. mediumTags temp , MediumTags =. mediumTags temp
@ -75,7 +75,7 @@ postMediumDeleteR mediumId = do
Just "confirm" -> do Just "confirm" -> do
-- delete comments -- delete comments
commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] [] commEnts <- runDB $ selectList [CommentOrigin ==. mediumId] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
-- delete references first -- delete references first
albumId <- return $ mediumAlbum medium albumId <- return $ mediumAlbum medium
album <- runDB $ getJust albumId album <- runDB $ getJust albumId

View file

@ -25,7 +25,7 @@ postNewAlbumR = do
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId userId <- return $ getUserIdFromText tempUserId
((result, albumWidget), enctype) <- runFormPost (albumForm userId) ((result, _), _) <- runFormPost (albumForm userId)
case result of case result of
FormSuccess album -> do FormSuccess album -> do
-- Put album in Database -- Put album in Database

View file

@ -37,7 +37,7 @@ getUserR :: Text -> Handler Html
getUserR ownerName = do getUserR ownerName = do
tempOwner <- runDB $ selectFirst [UserName ==. ownerName] [] tempOwner <- runDB $ selectFirst [UserName ==. ownerName] []
case tempOwner of case tempOwner of
Just (Entity ownerId owner) -> Just (Entity ownerId _) ->
getProfileR ownerId getProfileR ownerId
Nothing -> do Nothing -> do
setMessage "This user does not exist" setMessage "This user does not exist"

View file

@ -3,7 +3,6 @@ module Handler.ProfileDelete where
import Import import Import
import Handler.Commons import Handler.Commons
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe
import qualified Data.List as L import qualified Data.List as L
import System.Directory import System.Directory
import System.FilePath import System.FilePath
@ -29,12 +28,12 @@ postProfileDeleteR userId = do
case confirm of case confirm of
Just "confirm" -> do Just "confirm" -> do
albumList <- return $ userAlbums user albumList <- return $ userAlbums user
mapM (\albumId -> do _ <- mapM (\albumId -> do
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
mediaList <- return $ albumContent album mediaList <- return $ albumContent album
mapM (\med -> do _ <- mapM (\med -> do
commEnts <- runDB $ selectList [CommentOrigin ==. med] [] commEnts <- runDB $ selectList [CommentOrigin ==. med] []
mapM (\ent -> runDB $ delete $ entityKey ent) commEnts _ <- mapM (\ent -> runDB $ delete $ entityKey ent) commEnts
medium <- runDB $ getJust med medium <- runDB $ getJust med
liftIO $ removeFile (normalise $ L.tail $ mediumPath medium) liftIO $ removeFile (normalise $ L.tail $ mediumPath medium)
liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium) liftIO $ removeFile (normalise $ L.tail $ mediumThumb medium)

View file

@ -21,7 +21,7 @@ postProfileSettingsR userId = do
checkRes <- profileCheck userId checkRes <- profileCheck userId
case checkRes of case checkRes of
Right user -> do Right user -> do
((result, profileSettingsWidget), enctype) <- runFormPost $ profileSettingsForm user ((result, _), _) <- runFormPost $ profileSettingsForm user
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
runDB $ update userId [ runDB $ update userId [

View file

@ -13,7 +13,7 @@ getReactivateR = do
postReactivateR :: Handler Html postReactivateR :: Handler Html
postReactivateR = do postReactivateR = do
((result, reactivateWidget), enctype) <- runFormPost reactivateForm ((result, _), _) <- runFormPost reactivateForm
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
users <- runDB $ selectList [UserEmail ==. temp] [] users <- runDB $ selectList [UserEmail ==. temp] []
@ -21,10 +21,10 @@ postReactivateR = do
True -> do True -> do
userTokens <- foldM (\userTokens (Entity userId user) -> do userTokens <- foldM (\userTokens (Entity userId user) -> do
token <- liftIO $ generateString token <- liftIO $ generateString
tId <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId) _ <- runDB $ insert $ Token (encodeUtf8 token) "activate" (Just userId)
return $ (user, token) : userTokens return $ (user, token) : userTokens
) [] users ) [] users
sent <- foldM (\sent (user, token) -> _ <- foldM (\sent (user, token) ->
case sent of case sent of
False -> False ->
return False return False

View file

@ -53,8 +53,8 @@ postSignupR = do
[] []
False False
activatorText <- liftIO generateString activatorText <- liftIO generateString
aId <- runDB $ insert $ Activator activatorText newUser _ <- runDB $ insert $ Activator activatorText newUser
tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing _ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
activateLink <- ($ ActivateR activatorText) <$> getUrlRender activateLink <- ($ ActivateR activatorText) <$> getUrlRender
sendMail (userEmail newUser) "Please activate your account!" $ sendMail (userEmail newUser) "Please activate your account!" $
[shamlet| [shamlet|

View file

@ -2,7 +2,6 @@ module Handler.Tag where
import Import import Import
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe
getTagR :: Text -> Handler Html getTagR :: Text -> Handler Html
getTagR tag = do getTagR tag = do

View file

@ -5,14 +5,8 @@ import Data.Time
import Data.Maybe import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import qualified System.FilePath as FP import qualified System.FilePath as FP
import qualified Filesystem.Path as FSP
import Filesystem.Path.CurrentOS import Filesystem.Path.CurrentOS
import Graphics.ImageMagick.MagickWand import Graphics.ImageMagick.MagickWand
import Control.Monad.Trans.Resource
import Foreign
import Foreign.C.Types
import Foreign.C.String
import Helper
data TempMedium = TempMedium data TempMedium = TempMedium
{ tempMediumTitle :: Text { tempMediumTitle :: Text
@ -44,7 +38,7 @@ postUploadR = do
case msu of case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- lift $ pure $ getUserIdFromText tempUserId userId <- lift $ pure $ getUserIdFromText tempUserId
((result, uploadWidget), enctype) <- runFormPost (uploadForm userId) ((result, _), _) <- runFormPost (uploadForm userId)
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
fil <- return $ tempMediumFile temp fil <- return $ tempMediumFile temp
@ -88,8 +82,6 @@ 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
ownerId <- return $ albumOwner album ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of -- is anybody logged in case msu of -- is anybody logged in
Just tempUserId -> do Just tempUserId -> do
@ -117,8 +109,6 @@ postDirectUploadR albumId = do
case tempAlbum of -- does the album exist case tempAlbum of -- does the album exist
Just album -> do Just album -> do
ownerId <- return $ albumOwner album ownerId <- return $ albumOwner album
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
msu <- lookupSession "userId" msu <- lookupSession "userId"
case msu of -- is anybody logged in case msu of -- is anybody logged in
Just tempUserId -> do Just tempUserId -> do
@ -126,7 +116,7 @@ postDirectUploadR albumId = do
presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album)) presence <- return $ (userId == ownerId) || (userId `elem` (albumShares album))
case presence of -- is the logged in user the owner or is the album shared with him case presence of -- is the logged in user the owner or is the album shared with him
True -> do True -> do
((result, dUploadWidget), enctype) <- runFormPost (dUploadForm userId albumId) ((result, _), _) <- runFormPost (dUploadForm userId albumId)
case result of case result of
FormSuccess temp -> do FormSuccess temp -> do
fil <- return $ tempMediumFile temp fil <- return $ tempMediumFile temp
@ -134,8 +124,8 @@ postDirectUploadR albumId = do
case mime `elem` acceptedTypes of case mime `elem` acceptedTypes of
True -> do True -> do
albRef <- runDB $ getJust (tempMediumAlbum temp) albRef <- runDB $ getJust (tempMediumAlbum temp)
ownerId <- return $ albumOwner albRef refOwnerId <- return $ albumOwner albRef
path <- writeOnDrive fil ownerId albumId path <- writeOnDrive fil refOwnerId albumId
thumbPath <- generateThumb path ownerId albumId thumbPath <- generateThumb path ownerId albumId
medium <- return $ Medium medium <- return $ Medium
(tempMediumTitle temp) (tempMediumTitle temp)
@ -182,7 +172,7 @@ generateThumb path userId albumId = do
w1 <- getImageWidth w w1 <- getImageWidth w
h1 <- getImageHeight w h1 <- getImageHeight w
h2 <- return 220 h2 <- return 220
w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2)) w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double)
resizeImage w w2 h2 lanczosFilter 1 resizeImage w w2 h2 lanczosFilter 1
setImageCompressionQuality w 95 setImageCompressionQuality w 95
writeImage w (Just (decodeString newPath)) writeImage w (Just (decodeString newPath))

View file

@ -4,23 +4,16 @@ import Prelude
import Yesod.Static import Yesod.Static
import Model import Model
import Control.Applicative import Control.Applicative
import Control.Monad.Trans.Class
import Data.Maybe import Data.Maybe
import Data.Either
import Data.List import Data.List
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time import Data.Time
import Data.Char import Data.Char
import Database.Persist import Database.Persist
import Database.Persist.Types
import System.FilePath
import System.Random import System.Random
import System.Locale import System.Locale
import Yesod.Persist.Core
import Yesod.Core.Types
import Yesod import Yesod
import Numeric (readHex, showHex) import Numeric (readHex, showHex)
import Network.Mail.Mime import Network.Mail.Mime
@ -77,7 +70,7 @@ tagField = Field
False -> return $ Right $ Just $ removeItem "" $ T.splitOn " " x False -> return $ Right $ Just $ removeItem "" $ T.splitOn " " x
True -> return $ Right $ Nothing True -> return $ Right $ Nothing
_ -> return $ Left $ error "unexpected tag list" _ -> return $ Left $ error "unexpected tag list"
, fieldView = \idAttr nameAttr val eResult isReq -> , fieldView = \idAttr nameAttr _ eResult _ ->
[whamlet|<input id=#{idAttr} type="text" name=#{nameAttr} value=#{either id (T.intercalate " ") eResult}>|] [whamlet|<input id=#{idAttr} type="text" name=#{nameAttr} value=#{either id (T.intercalate " ") eResult}>|]
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }
@ -95,7 +88,7 @@ userField users = Field
True -> return $ Left $ error "Invalid username list" True -> return $ Left $ error "Invalid username list"
True -> return $ Right $ Just $ [] True -> return $ Right $ Just $ []
_ -> return $ Left $ error "unexpected username list" _ -> return $ Left $ error "unexpected username list"
, fieldView = \idAttr nameAttr val eResult isReq -> , fieldView = \idAttr nameAttr _ eResult _ ->
[whamlet|<input id=#{idAttr} type="text" name=#{nameAttr} value=#{either id (getUsersFromResult users) eResult}>|] [whamlet|<input id=#{idAttr} type="text" name=#{nameAttr} value=#{either id (getUsersFromResult users) eResult}>|]
, fieldEnctype = UrlEncoded , fieldEnctype = UrlEncoded
} }

View file

@ -2,17 +2,7 @@ module Model where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Yesod.Markdown (Markdown) import Yesod.Markdown (Markdown)
import Data.Text (Text)
import Database.Persist.Quasi import Database.Persist.Quasi
import Database.Persist
import Database.Persist.TH
import Data.Typeable (Typeable)
import Data.Eq (Eq)
import Data.Time (UTCTime)
import Data.ByteString
import Data.Bool
import Data.Int
import Text.Show (Show)
import qualified System.FilePath as FP import qualified System.FilePath as FP
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.

View file

@ -1,12 +1,7 @@
module Settings.StaticFiles where module Settings.StaticFiles where
import Prelude (IO)
import Yesod.Static (staticFiles)
import qualified Yesod.Static as Static import qualified Yesod.Static as Static
import Settings (appStaticDir, compileTimeAppSettings) import Settings (appStaticDir, compileTimeAppSettings)
import Settings.Development
import Language.Haskell.TH (Q, Exp, Name)
import Data.Default (def)
-- | use this to create your static file serving site -- | use this to create your static file serving site
-- staticSite :: IO Static.Static -- staticSite :: IO Static.Static
@ -17,7 +12,7 @@ import Data.Default (def)
-- giving you compile-time verification that referenced files exist. -- giving you compile-time verification that referenced files exist.
-- Warning: any files added to your static directory during run-time can't be -- Warning: any files added to your static directory during run-time can't be
-- accessed this way. You'll have to use their FilePath or URL to access them. -- accessed this way. You'll have to use their FilePath or URL to access them.
staticFiles (appStaticDir compileTimeAppSettings) Static.staticFiles (appStaticDir compileTimeAppSettings)
-- combineSettings :: CombineSettings -- combineSettings :: CombineSettings
-- combineSettings = def -- combineSettings = def

View file

@ -3,7 +3,7 @@
<ul id="user-nav"> <ul id="user-nav">
<li> <li>
<a href=@{HomeR}>Home <a href=@{HomeR}>Home
$maybe userId <- msu $maybe _ <- msu
Logged in as <a href=@{UserR username}>#{slug}<br> Logged in as <a href=@{UserR username}>#{slug}<br>
<li> <li>
<a href=@{LogoutR}>Logout <a href=@{LogoutR}>Logout

View file

@ -38,7 +38,7 @@ $else
<a href=@{CommentReplyR commentId}>Reply to this comment <a href=@{CommentReplyR commentId}>Reply to this comment
$if userId == (commentAuthor comment) $if userId == (commentAuthor comment)
<a href=@{CommentDeleteR commentId}>Delete this comment <a href=@{CommentDeleteR commentId}>Delete this comment
$forall (Entity replyId reply) <- replies $forall (Entity _ reply) <- replies
$if commentParent reply == Just commentId $if commentParent reply == Just commentId
<div #comment class="reply"> <div #comment class="reply">
<a href=@{ProfileR $ fromJust $ commentAuthor reply}>#{fromJust $ commentAuthorSlug reply}</a> wrote on #{formatTime defaultTimeLocale "%A %F %H:%M" $ commentTime reply}: <a href=@{ProfileR $ fromJust $ commentAuthor reply}>#{fromJust $ commentAuthorSlug reply}</a> wrote on #{formatTime defaultTimeLocale "%A %F %H:%M" $ commentTime reply}: