From 56c1731d647a36d24726d49389eb668ea0b76dc7 Mon Sep 17 00:00:00 2001
From: nek0 <neko.rloove@rocketmail.com>
Date: Wed, 13 Aug 2014 18:18:35 +0200
Subject: [PATCH] upload now working

---
 Handler/Upload.hs       | 76 +++++++++++++++++++++++++++++++++++++++--
 config/models           |  3 +-
 templates/upload.hamlet | 10 ++++++
 3 files changed, 84 insertions(+), 5 deletions(-)
 create mode 100644 templates/upload.hamlet

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|<pre>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|<pre>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|<input id=#{idAttr} type="text" name=#{nameAttr}>|]
+  , 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 @@
+<h3>Image upload
+
+Here you can upload your image.
+
+
+
+<form method=post enctype=#{enctype}>
+  ^{uploadWidget}
+  <div>
+    <input type=submit value="Upload">