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. + + + +
+ ^{uploadWidget} +
+