module Yesod.Transloadit (
YesodTransloadit(..),
mkParams,
transloadIt,
handleTransloadit,
tokenText,
extractFirstResult,
ParamsResult,
ParamsError(..),
Key(..),
Template(..),
Secret(..),
TransloaditParams,
Signature
) where
import Control.Applicative
import Control.Lens.Operators hiding ((.=))
import Control.Monad (mzero)
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 Data.Maybe
import Data.Monoid
import Data.Text
import Data.Text.Encoding
import Data.Time
import qualified System.Locale as SL
import Text.Julius
import Yesod hiding (Key)
import Yesod.Form.Jquery (YesodJquery (..))
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 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)
data Upload = Upload Text deriving (Show)
instance FromJSON Upload where
parseJSON (Object o) = Upload <$> (o .: "ssl_url")
parseJSON _ = mzero
formatExpiryTime :: UTCTime -> Text
formatExpiryTime = pack . formatTime SL.defaultTimeLocale "%Y/%m/%d %H:%M:%S+00:00"
instance ToJSON TransloaditParams where
toJSON (TransloaditParams a (Key k) (Template t) _ _) = object [
"auth" .= object [
"key" .= k,
"expires" .= (formatExpiryTime a)
],
"template_id" .= t
]
encodeParams :: TransloaditParams -> Text
encodeParams (TransloaditParams a (Key k) (Template t) _ _) = mconcat [
"{\"auth\":{\"expires\":\"", (formatExpiryTime a),
"\",\"key\":\"", k, "\"},",
"\"template_id\":\"", 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
addScriptEither $ urlJqueryJs master
addScriptRemote $ root <> "jquery.transloadit2-v2-latest.js"
toWidget [julius|
$(function() {
$('##{rawJS formIdent}').transloadit({
wait : true,
params : JSON.parse('#{(rawJS . 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 $ case (token d == t) of
True -> return $ raw d
_ -> Nothing
extractFirstResult :: AsValue s => Text -> Maybe s -> Maybe Value
extractFirstResult _ Nothing = Nothing
extractFirstResult k (Just uploads) = uploads ^? AL.key "results" . AL.key k . nth 0 . AL.key "ssl_url"