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
class YesodTransloadit master where
transloaditRoot :: master -> Text
transloaditRoot _ = "https://assets.transloadit.com/js/"
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)
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
mkParams :: UTCTime
-> Key
-> Template
-> Text
-> 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 :: 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'
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
tokenText :: (YesodJquery m, YesodTransloadit m) => WidgetT m IO Text
tokenText = do
csrfToken <- fmap reqToken getRequest
return $ fromMaybe mempty csrfToken
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
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