Upload.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeSynonymInstances  #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
module Servant.Upload where

import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B8
import Network.Wai.Parse
import Servant
import Servant.Server.Internal
import System.Directory
import System.FilePath
import Control.Monad.Trans.Resource (runResourceT,withInternalState)

data Mem
data Tmp

class KnownBackend b where
  type Storage b :: *

  withBackend :: Proxy b -> (BackEnd (Storage b) -> IO r) -> IO r

instance KnownBackend Mem where
  type Storage Mem = ByteString

  withBackend Proxy f = f lbsBackEnd

instance KnownBackend Tmp where
  type Storage Tmp = FilePath

  withBackend Proxy f = runResourceT . withInternalState $ \s ->
    f (tempFileBackEnd s)

data Files b

type MultiPartData b = ([Param], [File (Storage b)])
type MultiPartDataT b = (MultiPartData b -> IO (MultiPartData b)) -> IO (MultiPartData b)

type FilesMem = Files Mem
type FilesTmp = Files Tmp

instance (KnownBackend b, HasServer sublayout config) => HasServer (Files b :> sublayout) config where
  type ServerT (Files b :> sublayout) m =
    MultiPartDataT b -> ServerT sublayout m

  route Proxy config subserver = route (Proxy :: Proxy sublayout) config (addBodyCheck subserver bodyCheck)
    where
      bodyCheck = withRequest $ \request ->
             return $ \f -> withBackend (Proxy :: Proxy b) $ \pb -> parseRequestBody pb request >>= f
--------------------------------------------------------------------------------
-- Example use
--------------------------------------------------------------------------------
--type API = "files" :> FilesMem :> Post '[JSON] ()
--      :<|> Raw
--
--api :: Proxy API
--api = Proxy
--
--server :: Server API
--server = handleFilesMem handler :<|> serveDirectory "."
--
handleFilesMem :: MultiPartDataT Mem -> IO (MultiPartData Mem)
handleFilesMem multipart = multipart return
--handleFilesMem multipart = multipart $ \(params,files) -> do
--  putStrLn "start"
--  mapM_ ppFile files
--  print params
--  putStrLn "end"
--  return (params,files)
--  where
--    ppFile :: File BL.ByteString -> IO ()
--    ppFile (name',fileinfo) = do
--      B8.putStrLn $ "Input name: " <> name'
--      B8.putStrLn $ "File name: " <> fileName fileinfo
--      B8.putStrLn $ "Content type: " <>  fileContentType fileinfo
--      putStrLn "---------------------------------"

handleFilesTmp :: FilePath -> MultiPartDataT Tmp -> IO (MultiPartData Tmp)
handleFilesTmp dest multipart = multipart $ \(params,files) -> do
  createDirectoryIfMissing True dest
  --putStrLn "start"
  newFiles <- mapM ppFile files
  --print params
  --putStrLn "end"
  return (params,newFiles)
  where
    ppFile (name',fileinfo) = do
      --B8.putStrLn $ "Input name: " <> name'
      --B8.putStrLn $ "File name: " <> fileName fileinfo
      --B8.putStrLn $ "Content type: " <>  fileContentType fileinfo
      --putStrLn (fileContent fileinfo)
      --putStrLn "---------------------------------"
      fileExists <- doesFileExist (fileContent fileinfo)
      let tmpFile = fileContent fileinfo
          destFile = dest </> B8.unpack (fileName fileinfo)
      case fileExists of
        True -> do --putStrLn $ unwords ["moving",tmpFile,"to",destFile]
                   renameFile tmpFile destFile
                   return (name',fileinfo{fileContent = destFile})
        False -> return (name',fileinfo)

handleFilesTmpRelative :: FilePath -> MultiPartDataT Tmp -> IO (MultiPartData Tmp)
handleFilesTmpRelative dest dat =
  ((</> dest) <$> getCurrentDirectory) >>= (`handleFilesTmp` dat)