module Text.Digestive.Snap
( SnapPartPolicy
, SnapFormConfig (..)
, defaultSnapFormConfig
, runForm
, runFormWith
) where
import Control.Applicative ((<$>))
import Control.Monad.Trans (liftIO)
import Data.Maybe (catMaybes, fromMaybe)
import System.Directory (copyFile, getTemporaryDirectory)
import System.FilePath (takeFileName, (</>))
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.ByteString.Char8 as B
import qualified Data.Text.Encoding as T
import qualified Snap.Core as Snap
import qualified Snap.Util.FileUploads as Snap
import Text.Digestive.Form
import Text.Digestive.Form.Encoding
import Text.Digestive.Types
import Text.Digestive.View
type SnapPartPolicy = Snap.PartInfo -> Snap.PartUploadPolicy
data SnapFormConfig = SnapFormConfig
{
method :: Maybe Method
, temporaryDirectory :: Maybe FilePath
, uploadPolicy :: Snap.UploadPolicy
, partPolicy :: SnapPartPolicy
}
defaultSnapFormConfig :: SnapFormConfig
defaultSnapFormConfig = SnapFormConfig
{ method = Nothing
, temporaryDirectory = Nothing
, uploadPolicy = Snap.defaultUploadPolicy
, partPolicy = const $ Snap.allowWithMaximumSize (128 * 1024)
}
snapEnv :: Snap.MonadSnap m => [(Text, FilePath)] -> Env m
snapEnv allFiles path = do
inputs <- map (TextInput . T.decodeUtf8) . findParams <$> Snap.getParams
let files = map (FileInput . snd) $ filter ((== name) . fst) allFiles
return $ inputs ++ files
where
findParams = fromMaybe [] . M.lookup (T.encodeUtf8 name)
name = fromPath path
snapFiles :: Snap.MonadSnap m => SnapFormConfig -> m [(Text, FilePath)]
snapFiles config = do
tmpDir <- liftIO $ maybe getTemporaryDirectory return $
temporaryDirectory config
Snap.handleFileUploads tmpDir (uploadPolicy config) (partPolicy config) $
fmap catMaybes . mapM (storeFile tmpDir)
where
storeFile _ (_, Left _) = return Nothing
storeFile tmp (partinfo, Right path) = do
let newPath = tmp </> "_" ++ takeFileName path ++
maybe "" B.unpack (Snap.partFileName partinfo)
liftIO $ copyFile path newPath
return $ Just (T.decodeUtf8 $ Snap.partFieldName partinfo, newPath)
runForm :: Snap.MonadSnap m
=> Text
-> Form v m a
-> m (View v, Maybe a)
runForm = runFormWith defaultSnapFormConfig
runFormWith :: Snap.MonadSnap m
=> SnapFormConfig
-> Text
-> Form v m a
-> m (View v, Maybe a)
runFormWith config name form = do
m <- maybe snapMethod return (method config)
case m of
Get -> do
view <- getForm name form
return (view, Nothing)
Post ->
postForm name form $ \encType -> case encType of
UrlEncoded -> return $ snapEnv []
MultiPart -> snapEnv <$> snapFiles config
where
snapMethod = toMethod . Snap.rqMethod <$> Snap.getRequest
toMethod Snap.GET = Get
toMethod _ = Post