diff --git a/Handler/Upload.hs b/Handler/Upload.hs index f30f7a6..c3d130b 100644 --- a/Handler/Upload.hs +++ b/Handler/Upload.hs @@ -1,9 +1,79 @@ module Handler.Upload where -import Import +import Import as I +import Data.Time +import Data.Text +import System.FilePath + +data TempMedium = TempMedium + { tempMediumTitle :: Text + , tempMediumFile :: FileInfo + , tempMediumTime :: UTCTime + , tempMediumOwner :: Text + , tempMediumDesc :: Textarea + , tempMediumTags :: [Text] + } getUploadR :: Handler Html -getUploadR = error "Not yet implemented: getUploadR" +getUploadR = do + msu <- lookupSession "username" + case msu of + Just username -> do + (uploadWidget, enctype) <- generateFormPost (uploadForm username) + defaultLayout $ do + $(widgetFile "upload") + Nothing -> do + setMessage $ [shamlet|
You need to be logged in|] + redirect $ LoginR postUploadR :: Handler Html -postUploadR = error "Not yet implemented: postUploadR" +postUploadR = do + msu <- lookupSession "username" + case msu of + Just username -> do + ((result, uploadWidget), enctype) <- runFormPost (uploadForm username) + case result of + FormSuccess temp -> do + path <- writeOnDrive $ tempMediumFile temp + medium <- return $ Medium + (tempMediumTitle temp) + path + (tempMediumTime temp) + (tempMediumOwner temp) + (tempMediumDesc temp) + (tempMediumTags temp) + mId <- runDB $ insert medium + setMessage $ [shamlet|Image succesfully uploaded|] + redirect $ HomeR + _ -> do + setMessage $ [shamlet|There was an error uploading the file|] + redirect $ UploadR + Nothing -> do + setMessage $ [shamlet|You need to be logged in|] + redirect $ LoginR + +writeOnDrive :: FileInfo -> Handler FilePath +writeOnDrive file = do + filename <- return $ fileName file + path <- return $ "static" > (unpack filename) + liftIO $ fileMove file path + return path + +uploadForm :: Text -> Form TempMedium +uploadForm username = renderDivs $ TempMedium + <$> areq textField "Title" Nothing + <*> areq fileField "Select file" Nothing + <*> lift (liftIO getCurrentTime) + <*> pure username + <*> areq textareaField "Description" Nothing + <*> areq tagField "Enter tags" Nothing + +tagField :: Field Handler [Text] +tagField = Field + { fieldParse = \rawVals _ -> do + case rawVals of + [x] -> return $ Right $ Just $ splitOn " " x + , fieldView = \idAttr nameAttr _ eResult isReq -> + [whamlet||] + , fieldEnctype = UrlEncoded + } diff --git a/config/models b/config/models index 519887f..3baed98 100644 --- a/config/models +++ b/config/models @@ -13,10 +13,9 @@ Album Medium title Text path FilePath - thumbPath FilePath time UTCTime owner Text - description Text + description Textarea tags [Text] -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/templates/upload.hamlet b/templates/upload.hamlet new file mode 100644 index 0000000..6c49a3d --- /dev/null +++ b/templates/upload.hamlet @@ -0,0 +1,10 @@ +Image upload + +Here you can upload your image. + + + +