-- | Module providing a Snap backend for the digestive-functors library
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
    { -- | Can be used to override the method detected by Snap, in case you e.g.
      -- want to perform a 'postForm' even in case of a GET request.
      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

-- | 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...
    fmap catMaybes $ Snap.handleFileUploads tmpDir (uploadPolicy config) (partPolicy config) $
        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. Set 'method' in the 'SnapFormConfig' to override this behaviour.
runForm :: Snap.MonadSnap m
        => Text                 -- ^ Name for the form
        -> Form v m a           -- ^ Form to run
        -> m (View v, Maybe a)  -- ^ Result
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. Set 'method' in the 'SnapFormConfig' to override this behaviour.
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 = 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