digestive-functors-snap 0.3.0.0 → 0.3.1.0
raw patch · 2 files changed
+78/−12 lines, 2 filesdep +bytestringdep +directorydep +filepath
Dependencies added: bytestring, directory, filepath, mtl
Files
- digestive-functors-snap.cabal +6/−2
- src/Text/Digestive/Snap.hs +72/−10
digestive-functors-snap.cabal view
@@ -1,5 +1,5 @@ Name: digestive-functors-snap-Version: 0.3.0.0+Version: 0.3.1.0 Synopsis: Snap backend for the digestive-functors library Description: Snap backend for the digestive-functors library Homepage: http://github.com/jaspervdj/digestive-functors@@ -21,4 +21,8 @@ containers >= 0.3 && < 0.5, digestive-functors >= 0.3 && < 0.4, snap-core >= 0.7 && < 0.9,- text >= 0.11 && < 0.12+ text >= 0.11 && < 0.12,+ directory >= 1.0 && < 1.2,+ filepath >= 1.0 && < 1.4,+ mtl >= 2 && < 3,+ bytestring >= 0.9 && < 0.10
src/Text/Digestive/Snap.hs view
@@ -1,28 +1,75 @@ -- | Module providing a Snap backend for the digestive-functors library module Text.Digestive.Snap- ( runForm+ ( SnapPartPolicy+ , SnapFormConfig (..)+ , defaultSnapFormConfig+ , runForm+ , runFormWith ) where import Control.Applicative ((<$>))-import Data.Maybe (fromMaybe)+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 -snapEnv :: Snap.MonadSnap m => Env m-snapEnv path =- map (TextInput . T.decodeUtf8) . findParams <$> Snap.getPostParams+type SnapPartPolicy = Snap.PartInfo -> Snap.PartUploadPolicy++data SnapFormConfig = SnapFormConfig+ { temporaryDirectory :: Maybe FilePath+ , uploadPolicy :: Snap.UploadPolicy+ , partPolicy :: SnapPartPolicy+ }++defaultSnapFormConfig :: SnapFormConfig+defaultSnapFormConfig = SnapFormConfig+ { 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.getPostParams+ let files = map (FileInput . snd) $ filter ((== name) . fst) allFiles+ return $ inputs ++ files where- findParams = fromMaybe [] . M.lookup name - name = T.encodeUtf8 $ fromPath path+ findParams = fromMaybe [] . M.lookup (T.encodeUtf8 name)+ name = fromPath path --- | Runs a form with the HTTP input provided by Happstack.+-- | Deals with uploaded files, by placing each file in the temporary directory+-- specified in the configuration. It returns a mapping of names to the+-- temporary files.+snapFiles :: Snap.MonadSnap m => SnapFormConfig -> m [(Text, FilePath)]+snapFiles config = do+ -- Get the temporary dir or use the one provided by the OS+ tmpDir <- liftIO $ maybe getTemporaryDirectory return $+ temporaryDirectory config++ -- Actually do the work...+ 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)++-- | Runs a form with the HTTP input provided by Snap. -- -- Automatically picks between 'getForm' and 'postForm' based on the request -- method.@@ -30,7 +77,22 @@ => Text -- ^ Name for the form -> Form v m a -- ^ Form to run -> m (View v, Maybe a) -- ^ Result-runForm name form = Snap.getRequest >>= \rq ->+runForm = runFormWith defaultSnapFormConfig++-- | Runs a form with a custom upload policy, and HTTP input from snap.+--+-- Automatically picks between 'getForm' and 'postForm' based on request+-- method.+runFormWith :: Snap.MonadSnap m+ => SnapFormConfig -- ^ Tempdir and upload policies+ -> Text -- ^ Name for the form+ -> Form v m a -- ^ Form to run+ -> m (View v, Maybe a) -- ^ Result+runFormWith config name form = Snap.getRequest >>= \rq -> case Snap.rqMethod rq of Snap.GET -> return (getForm name form, Nothing)- _ -> postForm name form snapEnv+ _ -> do+ files <- case formEncType form of+ UrlEncoded -> return []+ MultiPart -> snapFiles config+ postForm name form (snapEnv files)