module Network.Kraken
( Config(..)
, Handle
, newHandle
, Quality(..), Resize(..), Format(..), Convert(..), Options(..)
, compressImage
) where
import Control.Applicative
import Control.Monad.Except
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Aeson hiding (Success, Error)
import Data.Aeson.Types hiding (Success, Error, Options)
import Data.Maybe
import Network.HTTP.Client hiding (Response)
import Network.HTTP.Client.MultipartFormData
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Prelude
data Config = Config
{ cApiKey :: !String
, cApiSecret :: !String
}
data Handle = Handle
{ hConfig :: Config
, hManager :: Manager
}
data Quality = Lossless | Lossy !Int
data Resize
= Exact !Int !Int
| Portrait !Int
| Landscape !Int
| Auto !Int !Int
| Fit !Int !Int
| Crop !Int !Int
| Square !Int
| Fill !Int !Int !String
instance ToJSON Resize where
toJSON (Exact w h) = strategy "exact" [ "width" .= w, "height" .= h ]
toJSON (Portrait h) = strategy "portrait" [ "height" .= h ]
toJSON (Landscape w) = strategy "landscape" [ "width" .= w ]
toJSON (Auto w h) = strategy "auto" [ "width" .= w, "height" .= h ]
toJSON (Fit w h) = strategy "fit" [ "width" .= w, "height" .= h ]
toJSON (Crop w h) = strategy "crop" [ "width" .= w, "height" .= h ]
toJSON (Square s) = strategy "square" [ "size" .= s ]
toJSON (Fill w h bg) = strategy "fill" [ "width" .= w, "height" .= h, "background" .= bg ]
strategy :: String -> [Pair] -> Value
strategy s r = object $ [ "strategy" .= s ] ++ r
data Format = JPEG | PNG | GIF
instance ToJSON Format where
toJSON JPEG = String "jpeg"
toJSON PNG = String "png"
toJSON GIF = String "gif"
data Convert = Convert
{ format :: Format
, background :: !(Maybe String)
, keepExtension :: !(Maybe Bool)
}
data Options = Options
{ quality :: !(Maybe Quality)
, resize :: !(Maybe Resize)
, convert :: !(Maybe Convert)
}
renderOptions :: Options -> [Pair]
renderOptions o = concat $ catMaybes
[ fmap qualityPairs (quality o)
, (\r -> ["resize" .= r]) <$> (resize o)
, fmap convertPairs (convert o)
]
where
qualityPairs Lossless = [ "lossy" .= False ]
qualityPairs (Lossy q) = [ "lossy" .= True, "quality" .= q ]
convertPairs x =
[ "convert" .= object (catMaybes
[ Just $ "format" .= format x
, ("background" .=) <$> (background x)
, ("keep_extension" .=) <$> (keepExtension x)
])
]
data Success = Success
{ krakedUrl :: !String
} deriving (Show)
data Error = Error !String
deriving (Show)
responseParser :: Value -> Parser (Either Error Success)
responseParser (Object o) = o .: "success" >>= \success ->
if success
then Right . Success <$> o .: "kraked_url"
else Left . Error <$> o .: "error"
responseParser _ = fail "Kraken API Response"
newHandle :: Config -> IO Handle
newHandle c = do
manager <- newManager tlsManagerSettings
return $ Handle c manager
compressImage :: Handle -> Options -> ByteString -> IO (Either Error ByteString)
compressImage h opt img = do
req <- insertRequestBody $ parseRequest_ "https://api.kraken.io/v1/upload"
res <- httpLbs req (hManager h)
runExceptT $ do
v <- case eitherDecode' (responseBody res) of
Left e -> throwError $ Error e
Right x -> return x
r <- case parseEither responseParser v of
Left e -> throwError $ Error e
Right x -> ExceptT $ return x
ExceptT $ downloadBinary (hManager h) (krakedUrl r)
where
config = hConfig h
options = object $
[ "auth" .= object
[ "api_key" .= cApiKey config
, "api_secret" .= cApiSecret config
]
, "wait" .= True
] ++ renderOptions opt
insertRequestBody :: Request -> IO Request
insertRequestBody = formDataBody
[ partLBS "options" $ encode options
, (partBS "file" img) { partFilename = Just "kraken" }
]
downloadBinary :: Manager -> String -> IO (Either Error ByteString)
downloadBinary m url = runExceptT $ do
req <- ExceptT $ return $ case parseRequest url of
Nothing -> throwError $ Error $ "Failed to parse download URL: " ++ url
Just x -> return x
res <- ExceptT $ Right <$> httpLbs req m
ExceptT $ return $ Right $ toStrict $ responseBody res