enabled temporary uploads

Foundation.hs

@@ -15,6 +15,7 @@ module Foundation
     , getBlogTitle
     , getBlogDescription
     , markupRender
+    , markupRender'
     , isAdmin
     , notice
     , commentAnchor
@@ -24,6 +25,7 @@ module Foundation
     ) where
 
 import Prelude
+import Data.Data
 import Yesod
 import Yesod.Static
 import Settings.StaticFiles
@@ -40,7 +42,6 @@ import qualified Settings
 import qualified Data.ByteString.Lazy as L
 import qualified Database.Persist.Store
 import Database.Persist.MongoDB hiding (master)
-import Settings (widgetFile, Extra (..))
 import Model
 import Text.Jasmine (minifym)
 import Web.ClientSession (getKey)
@@ -115,13 +116,20 @@ isAdmin usr = do
   as <- extraAdmins . appExtra . settings <$> getYesod
   return $ userIdent usr `elem` as
 
-markupRender :: Maybe String -> Article -> GHandler sub Yablog Html
-markupRender mid article = do
+markupRender' :: Data a => Maybe String
+              -> (a -> GHandler sub Yablog a)
+              -> Article
+              -> GHandler sub Yablog Html
+markupRender' mid tran article = do
   extra <- appExtra . settings <$> getYesod
   usr <- runDB $ get404 $ articleAuthor article
   let markup = fromMaybe "markdown" $ articleMarkup article <|> extraMarkup extra
-      trans  = bottomUp (procAttach article) . (maybe id (addAmazonAssociateLink . T.unpack) $ userAmazon usr)
-  return $ renderMarkup mid markup trans $ articleBody article
+  let trans = bottomUpM tran . bottomUp (procAttach article)
+              . (maybe id (addAmazonAssociateLink . T.unpack) $ userAmazon usr)
+  renderMarkup mid markup trans $ articleBody article
+
+markupRender :: Maybe String -> Article -> GHandler sub Yablog Html
+markupRender mid = markupRender' mid (return :: Pandoc -> GHandler sub Yablog Pandoc)
 
 dayToString :: Day -> String
 dayToString = formatTime defaultTimeLocale "%Y%m%d"

Handler/Blog.hs

@@ -20,7 +20,10 @@ import Network.HTTP.Conduit hiding (def)
 import Network.HTTP.Types
 import qualified Network.Wai as W
 import System.Directory
+import Control.Monad.Trans.Resource
 import System.FilePath
+import System.IO.Temp
+import Network.URI
 
 postCreateR :: Handler RepHtml
 postCreateR = do
@@ -311,11 +314,31 @@ postPreviewR = do
           mnext    = Nothing
           mprev    = Nothing
       blogTitle <- getBlogTitle
-      body <- markupRender Nothing article
+      body <- markupRender' Nothing (procTemporaryFile article) article
       defaultLayout $ do
         $(widgetFile "article-view")
     _ -> notFound
 
+procTemporaryFile :: Article -> Inline -> Handler Inline
+procTemporaryFile article inl =
+  case inl of
+    Image is targ -> Image is <$> rewrite targ
+    Link  is targ -> Link  is <$> rewrite targ
+    _             -> return inl
+  where
+    rewrite (url, a)
+      | isRelativeReference url && not ("/" `isPrefixOf` url) = do
+          (_, files) <- runRequestBody
+          tmpDir <- liftIO $ createTempDirectory (attachmentDir article) "temp"
+          register $ liftIO $ removeDirectoryRecursive tmpDir
+          forM_ files $ \(param, finfo) -> when ("file" `T.isPrefixOf` param) $ do
+            liftIO $ LBS.writeFile (tmpDir </> T.unpack (fileName finfo)) $ fileContent finfo
+          let atts = map (fileName . snd) files
+          if T.pack url `elem` atts
+             then return ("/" </> tmpDir </> url, a)
+             else return ("/" </> attachmentDir article </> url, a)
+      | otherwise = return (url, a)
+
 getTagR :: Text -> Handler RepHtml
 getTagR tag = do
   articles <- runDB $ do

Markups.hs

@@ -12,6 +12,7 @@ import Yesod hiding (insert)
 import Data.Maybe
 import Prelude
 import Data.Char
+import Control.Monad
 
 renderTwitterLink :: Pandoc -> Pandoc
 renderTwitterLink = bottomUp go
@@ -24,13 +25,14 @@ renderTwitterLink = bottomUp go
 addAmazonAssociateLink :: String -> Pandoc -> Pandoc
 addAmazonAssociateLink = bottomUp . procAmazon
 
-renderMarkup :: Maybe String
-             -> String             -- ^ markup language
-             -> (Pandoc -> Pandoc) -- ^ pandoc transformer
-             -> String             -- ^ source
-             -> Html               -- ^ Html
+renderMarkup :: Monad m
+             => Maybe String
+             -> String               -- ^ markup language
+             -> (Pandoc -> m Pandoc) -- ^ pandoc transformer
+             -> String               -- ^ source
+             -> m Html               -- ^ Html
 renderMarkup mid lang trans =
-    writeHtml opts
+    liftM (writeHtml opts)
                   . trans . renderTwitterLink
                   . fromMaybe readMarkdown (lookup (map toLower lang) readers) defaultParserState
   where

Yablog.cabal

@@ -127,6 +127,8 @@ executable         Yablog
                  , directory                     >= 1.1        && < 1.2
                  , containers                    >= 0.4        && < 0.5
                  , mtl                           >= 2.0        && < 2.1
+                 , temporary                     >= 1.1        && < 1.2
+                 , resourcet                     >= 0.3        && < 0.4
 
 source-repository head
   type:     git