module Network.Clarifai
(
VerificationStatus(..),
Client(..),
TagSet(..),
Info(..),
Tag(..),
verifyImageBatchSize,
verifyVideoBatchSize,
verifyFiles,
authorize,
info,
tag
) where
import qualified Control.Exception as E
import Control.Lens
import Data.Aeson
import Data.Aeson.Lens
import qualified Data.ByteString as BL
import qualified Data.ByteString.Char8 as BStrict
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Either
import Data.List
import qualified Data.Map.Lazy as Map
import qualified Data.Text as T
import qualified Data.Vector as V
import Network.HTTP
import qualified Network.HTTP.Client as Net
import Network.Utilities
import Network.Wreq
import System.EasyFile
data Client = Client String | App String String deriving (Show)
authHeader :: Client -> Options
authHeader (Client token) = defaults' & header "Authorization" .~ [packed]
where auth = "Bearer " ++ token
packed = BStrict.pack auth
authHeader _ = defaults
data Info = Info {
maxBatchSize :: Integer,
maxImageSize :: Integer,
minImageSize :: Integer,
maxImageBytes :: Integer,
maxVideoBatchSize :: Integer,
maxVideoSize :: Integer,
minVideoSize :: Integer,
maxVideoBytes :: Integer,
maxVideoDuration :: Integer
} deriving (Show)
toInfo :: Obj -> Info
toInfo origObj = Info mbs maxis minis maxib mvbs maxvs minvs mvb mvd
where obj = getMap "results" origObj
mbs = getInt' "max_batch_size" obj
maxis = getInt' "max_image_size" obj
minis = getInt' "min_image_size" obj
maxib = getInt' "max_image_bytes" obj
mvbs = getInt' "max_video_batch_size" obj
maxvs = getInt' "max_video_size" obj
minvs = getInt' "min_video_size" obj
mvb = getInt' "max_video_bytes" obj
mvd = getInt' "max_video_duration" obj
data Tag = Tag String Double deriving (Show)
data TagSet = TagSet {
docID :: Integer,
localID :: String,
tags :: V.Vector Tag
} deriving (Show)
getTags :: HObj -> V.Vector Tag
getTags o = V.map (uncurry Tag) (V.zip classes probs)
where classes = V.map value2String (getVec' "classes" o)
probs = V.map value2Double (getVec' "probs" o)
objToTagSet :: HObj -> TagSet
objToTagSet o = TagSet docID localID tags
where docID = getInt' "docid" o
localID = getString' "local_id" o
tags = getTags (getMap' "tag" $ getMap' "result" o)
tokenUrl = "https://api.clarifai.com/v1/token/"
infoUrl = "https://api.clarifai.com/v1/info/"
tagUrl = "https://api.clarifai.com/v1/tag/"
authorize :: Client -> IO (Either Errors Client)
authorize (Client token) = return (Right (Client token))
authorize (App clientID clientSecret) = resp
where params = ["client_id" := clientID,
"client_secret" := clientSecret,
"grant_type" := BS.pack "client_credentials"]
key = "access_token"
resp = do (status, body) <- processRequest $ postWith' tokenUrl params
let code = status ^. statusCode in
if code /= 200 then
return (Left (code, apiErr code body))
else
return (Right (Client $ getString key body))
info :: Client -> IO (Either Errors Info)
info (App _ _) = return (Left (0, "You have not authorized your app yet."))
info client = resp
where opts = authHeader client
resp = do (status, body) <- processRequest $ getWith opts infoUrl
let code = status ^. statusCode in
if code /= 200 then
return (Left (code, apiErr code body))
else
return (Right (toInfo body))
tag :: Client -> [FilePath] -> IO (Either Errors (V.Vector TagSet))
tag (App _ _) _ = return (Left (0, "You have not authorized your app yet."))
tag c fs = resp
where opts = authHeader c
toParts = partFile "encoded_data"
files = map toParts fs
resp = do (status, body) <- processRequest $ postWith opts tagUrl files
let extractedVec = vecOfObjects $ getVec "results" body
let code = status ^. statusCode in
if code /= 200 then
return (Left (code, apiErr code body))
else
return (Right (V.map objToTagSet extractedVec))
where
vecOfObjects :: V.Vector Value -> V.Vector HObj
vecOfObjects = V.map value2Map
verifyFiles :: Info -> [FilePath] -> IO [(FilePath, IO VerificationStatus)]
verifyFiles info fs = do
let zipped = zip fs (map getFileSize fs)
return (map (verify info) zipped)
where verify (Info _ _ _ ib _ _ _ _ vb) (path, ioSize)
| ext `elem` imageExtensions = (path, fmap imgC ioSize)
| ext `elem` videoExtensions = (path, fmap vidC ioSize)
| otherwise = (path, return Unknown)
where ext = takeExtension path
vidC = fileCheck vb
imgC = fileCheck ib
verifyImageBatchSize :: Info -> [FilePath] -> Bool
verifyImageBatchSize (Info size _ _ _ _ _ _ _ _) xs = size >= conv
where conv = fromIntegral (length xs) :: Integer
verifyVideoBatchSize :: Info -> [FilePath] -> Bool
verifyVideoBatchSize (Info _ _ _ _ size _ _ _ _) xs = size >= conv
where conv = fromIntegral (length xs) :: Integer