kraken (empty) → 0.0.1

raw patch · 4 files changed

+234/−0 lines, 4 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, http-client, http-client-tls, mtl

Files

LICENSE +20/−0
Setup.hs +2/−0
kraken.cabal +41/−0
src/Network/Kraken.hs +171/−0

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2015 Tomas Carnecky++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ kraken.cabal view

@@ -0,0 +1,41 @@+name:                kraken+version:             0.0.1++synopsis:            Kraken.io API client+description:+  Kraken is a robust, ultra-fast image optimizer and compressor with+  best-in-class algorithms.++license:             MIT+license-file:        LICENSE++author:              Tomas Carnecky+maintainer:          tomas.carnecky@gmail.com++category:            Network++build-type:          Simple+cabal-version:       >=1.10+++source-repository head+    type:     git+    location: git://github.com/wereHamster/kraken-haskell.git+++library+  hs-source-dirs:      src+  default-language:    Haskell2010++  ghc-options:         -Wall++  exposed-modules:+     Network.Kraken++  build-depends:+     base >=4.5 && <4.9+   , bytestring+   , http-client+   , http-client-tls+   , aeson+   , mtl

+ src/Network/Kraken.hs view

@@ -0,0 +1,171 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Kraken+    ( Config(..)++    , Handle+    , newHandle++    , Quality(..), Resize(..), Format(..), Convert(..), Options(..)++    , compressImage+    ) where+++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)++++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)+            ])+        ]+++-------------------------------------------------------------------------------+-- JSON objects used in the API++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+    let Just req0 = parseUrl "https://api.kraken.io/v1/upload"+    req <- insertRequestBody req0+    res <- httpLbs (req { checkStatus = \_ _ _ -> Nothing }) (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 parseUrl 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