{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Yesod.Transloadit (
YesodTransloadit(..),
mkParams,
transloadIt,
handleTransloadit,
tokenText,
nthStepResult,
StepResult,
resultId,
name,
baseName,
extension,
mime,
field,
url,
sslUrl,
ParamsResult,
ParamsError(..),
Key(..),
Template(..),
Secret(..),
TransloaditParams,
Signature
) where
import Control.Applicative
import Control.Lens
import Control.Monad
import Crypto.Hash
import Data.Aeson
import Data.Aeson.Lens hiding (key)
import qualified Data.Aeson.Lens as AL
import qualified Data.ByteString as BS
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import Data.Monoid
import Data.Text
import Data.Text.Encoding
import Data.Time
import Text.Julius
import Yesod hiding (Key)
import Yesod.Form.Jquery (YesodJquery (..))
import Yesod.Transloadit.OrderedJSON hiding (encode)
import qualified Yesod.Transloadit.OrderedJSON as OJ
#if MIN_VERSION_time(1,5,0)
#else
import System.Locale (defaultTimeLocale)
#endif
-- | Typeclass for your website to enable using Transloadit.
class YesodTransloadit master where
-- | Override the 'transloaditRoot' to point at a different base Javascript directory.
-- The default settings will load assets from assets.transloadit.com.
transloaditRoot :: master -> Text
transloaditRoot _ = "https://assets.transloadit.com/js/"
{-# MINIMAL #-}
newtype Secret = Secret { secret :: BS.ByteString } deriving (Eq, Show)
newtype Key = Key { key :: Text } deriving (Eq, Show)
newtype Template = Template { template :: Text } deriving (Eq, Show)
data TransloaditParams = TransloaditParams {
authExpires :: UTCTime,
transloaditKey :: Key,
transloaditTemplate :: Template,
formIdent :: Text,
transloaditSecret :: Secret
} deriving (Show)
-- | The result of the execution of a single step
data StepResult = StepResult {
_resultId :: Text,
_name :: Text,
_baseName :: Text,
_extension :: Text,
_mime :: Text,
_field :: Text,
_url :: Text,
_sslUrl :: Text
} deriving (Show)
$(makeLenses ''StepResult)
data ParamsError = UnknownError
type ParamsResult = Either ParamsError TransloaditParams
-- | Smart constructor for Transloadit params
mkParams :: UTCTime -- ^ When the Transloadit signature should expire
-> Key -- ^ Transloadit key
-> Template -- ^ The Template to use in Transloadit
-> Text -- ^ The id of the form to attach to
-> Secret -- ^ Transloadit Secret
-> ParamsResult
mkParams u k t f s = return (TransloaditParams u k t f s)
data TransloaditResponse = TransloaditResponse { raw :: Text, token :: Text } deriving (Show)
formatExpiryTime :: UTCTime -> Text
formatExpiryTime = pack . formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S+00:00"
-- encodeParams is similar to the exported ToJSON instance, except that it gives us the same order
-- output of keys each time. This is very useful for testing that signatures are correct.
encodeParams :: TransloaditParams -> Text
encodeParams (TransloaditParams a (Key k) (Template t) _ _) = OJ.encode params
where params = obj [
"auth" `is` obj [
"expires" `is` str (formatExpiryTime a),
"key" `is` str k
],
"template_id" `is` str t
]
type Signature = Text
sign :: TransloaditParams -> Signature
sign cfg = (pack . show . hmacGetDigest) h
where h :: HMAC SHA1
h = hmac (s cfg) ((encodeUtf8 . encodeParams) cfg)
s (transloaditSecret -> Secret s') = s'
-- | Calculate the signature, and embed Javascript to attach Transloadit to the form.
transloadIt :: (YesodJquery m, YesodTransloadit m) => TransloaditParams -> WidgetT m IO Signature
transloadIt t@(TransloaditParams {..}) = do
master <- getYesod
let root = transloaditRoot master
signature = sign t
divId = mconcat ["#", formIdent]
addScriptEither $ urlJqueryJs master
addScriptRemote $ root <> "jquery.transloadit2-v2-latest.js"
toWidget [julius|
$(function() {
$(#{toJSON divId}).transloadit({
wait : true,
params : JSON.parse(#{(toJSON . encodeParams) t})
});
});
|]
return signature
-- | Helper method to grab the current CSRF token from the session. Returns 'mempty' if 'Nothing'
-- could be found.
tokenText :: (YesodJquery m, YesodTransloadit m) => WidgetT m IO Text
tokenText = do
csrfToken <- fmap reqToken getRequest
return $ fromMaybe mempty csrfToken
-- | Helper method to pull the Transloadit response and the CSRF token (named @_token@) from the request.
handleTransloadit :: (RenderMessage m FormMessage, YesodJquery m, YesodTransloadit m) => WidgetT m IO (Maybe Text)
handleTransloadit = do
d <- runInputPost $ TransloaditResponse <$> ireq hiddenField "transloadit"
<*> ireq hiddenField "_token"
t <- tokenText
return $ if token d == t then return (raw d) else Nothing
_stepResult :: Getter Object (Maybe StepResult)
_stepResult = to parseResult
parseResult :: Object -> Maybe StepResult
parseResult hm = StepResult <$> v "id"
<*> v "name"
<*> v "basename"
<*> v "ext"
<*> v "mime"
<*> v "field"
<*> v "url"
<*> v "ssl_url"
where v s = case HM.lookup s hm of
(Just (String t)) -> Just t
_ -> Nothing
-- | Helper method to pull the nth @StepResult@ for a given key from the Transloadit response
nthStepResult :: AsValue s => Int -> Text -> Maybe s -> Maybe StepResult
nthStepResult _ _ Nothing = Nothing
nthStepResult i k (Just u) = u ^? AL.key "results"
. AL.key k
. nth i
. _Object
. _stepResult
& join