diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013 Loyful + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Felipe Lessa , JP Moresmau nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ig.cabal b/ig.cabal new file mode 100644 --- /dev/null +++ b/ig.cabal @@ -0,0 +1,88 @@ +name: ig +version: 0.1 +synopsis: Bindings to Instagram's API. +homepage: https://github.com/loyful/ig +license: BSD3 +license-file: LICENSE +author: Felipe Lessa , JP Moresmau +maintainer: Loyful +copyright: (c) 2013 Loyful +category: Web +build-type: Simple +cabal-version: >=1.8 + +description: + This package exports bindings to Instagram's APIs (see + ). + . + While we would like to have a complete binding to Instagram's + API, this package is being developed on demand. If you need + something that has not been implemented yet, please send a pull + request or file an issue on GitHub + (). + . + A sample Yesod application demonstrating the API can be found at . + +source-repository head + type: git + location: git://github.com/loyful/ig.git + +flag debug + default: False + description: Print debugging info. + +library + hs-source-dirs: src + ghc-options: -Wall + exposed-modules: + Instagram +-- other-modules: + build-depends: + base >= 4 && < 5 + , bytestring >= 0.9 && < 0.11 + , text == 0.11.* + , transformers >= 0.2 && < 0.4 + , transformers-base + , monad-control + , resourcet + , conduit == 1.0.* + , http-types + , http-conduit == 1.9.* + , attoparsec == 0.10.* + , attoparsec-conduit == 1.0.* + , aeson >= 0.5 && < 0.7, + time, + data-default, + lifted-base, + unordered-containers + , crypto-api >= 0.11 && < 0.13 + , cryptohash >= 0.7 + , cryptohash-cryptoapi == 0.1.* + , base16-bytestring >= 0.1 + extensions: + OverloadedStrings + DeriveDataTypeable + -- -- Copied from fb-0.14.6, may be useful =). + -- EmptyDataDecls + -- GADTs + -- StandaloneDeriving + -- ScopedTypeVariables + -- GeneralizedNewtypeDeriving + -- TypeFamilies + -- FlexibleInstances + -- MultiParamTypeClasses + other-modules: + Instagram.Types, + Instagram.Monad, + Instagram.Auth, + Instagram.Users, + Instagram.RealTime, + Instagram.Tags, + Instagram.Relationships, + Instagram.Media, + Instagram.Comments, + Instagram.Likes, + Instagram.Locations, + Instagram.Geographies + if flag(debug) + cpp-options: -DDEBUG diff --git a/src/Instagram.hs b/src/Instagram.hs new file mode 100644 --- /dev/null +++ b/src/Instagram.hs @@ -0,0 +1,136 @@ +-- | the public API for Instagram access +module Instagram + ( + -- generic types and functions + InstagramT + ,runInstagramT + ,runResourceInIs + ,IGException + + -- authentication + ,RedirectUri + ,getUserAccessTokenURL1 + ,getUserAccessTokenURL2 + ,Credentials(..) + ,OAuthToken(..) + ,AccessToken(..) -- we open this type so that the api client can just use the token data outside of your type (as a simple Text) + ,User(..) + ,Scope(..) + + -- data + ,Envelope(..) + ,Pagination(..) + ,Media(..) + ,Position(..) + ,UserPosition(..) + ,Location(..) + ,ImageData(..) + ,Images(..) + ,Comment(..) + ,Collection(..) + ,NoResult + + -- user + ,UserID + ,getUser + ,SelfFeedParams(..) + ,getSelfFeed + ,RecentParams(..) + ,getRecent + ,SelfLikedParams(..) + ,getSelfLiked + ,UserSearchParams(..) + ,searchUsers + + -- real time + ,Aspect -- do not export constructor since only media is supported + ,media + ,CallbackUrl + ,Subscription(..) + ,createSubscription + ,listSubscriptions + ,deleteSubscriptions + ,SubscriptionRequest(..) + ,SubscriptionParams(..) + ,DeletionParams(..) + ,Update(..) + ,verifySignature + + -- Tags + ,Tag(..) + ,TagName + ,getTag + ,RecentTagParams(..) + ,getRecentTagged + ,searchTags + + -- relationships + ,OutgoingStatus(..) + ,IncomingStatus(..) + ,Relationship(..) + ,getFollows + ,getFollowedBy + ,getRequestedBy + ,getRelationship + ,setRelationShip + ,RelationShipAction(..) + + -- media + ,MediaID + ,getMedia + ,getPopularMedia + ,MediaSearchParams(..) + ,searchMedia + + -- comments + ,CommentID + ,getComments + ,postComment + ,deleteComment + + -- likes + ,getLikes + ,like + ,unlike + + -- locations + ,LocationID + ,getLocation + ,LocationMediaParams(..) + ,getLocationRecentMedia + ,LocationSearchParams(..) + ,searchLocations + + -- geographies + ,GeographyID + ,GeographyMediaParams(..) + ,getGeographyRecentMedia + + ) where + +import Instagram.Auth +import Instagram.Comments +import Instagram.Geographies +import Instagram.Likes +import Instagram.Locations +import Instagram.Media +import Instagram.Monad +import Instagram.RealTime +import Instagram.Relationships +import Instagram.Tags +import Instagram.Types +import Instagram.Users + + +-- debugging +--import Data.Aeson +--import qualified Data.ByteString.Lazy as BS +-- +--parse :: IO() +--parse = do +-- t<-BS.readFile "env1.json" +-- let d=eitherDecode t +-- print (d::Either String (Envelope [Media])) +-- return() + + diff --git a/src/Instagram/Auth.hs b/src/Instagram/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Auth.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | handle the authorization mecanism for Instagram +-- +module Instagram.Auth ( + RedirectUri, + getUserAccessTokenURL1, + getUserAccessTokenURL2 +) where + +import Instagram.Monad +import Instagram.Types + +import Data.Text hiding (map) +import Control.Monad (liftM) +import qualified Data.ByteString as BS (ByteString,intercalate) +import qualified Data.Text.Encoding as TE +import qualified Network.HTTP.Types as HT + +import Data.Conduit + +-- | the URI to redirect the user after she accepts/refuses to authorize the app +type RedirectUri = Text + +-- | get the authorize url to redirect your user to +getUserAccessTokenURL1 :: Monad m => + RedirectUri -- ^ the URI to redirect the user after she accepts/refuses to authorize the app + -> [Scope] -- ^ the requested scopes (can be empty for Basic) + -> InstagramT m Text -- ^ the URL to redirect the user to +getUserAccessTokenURL1 url scopes= do + cid<-liftM clientIDBS getCreds + bsurl<-getQueryURL "/oauth/authorize/" $ buildQuery cid ++ buildScopes scopes + return $ TE.decodeUtf8 bsurl + where + -- | build the query with client id and redirect URI + buildQuery :: BS.ByteString -> HT.SimpleQuery + buildQuery cid=[("client_id",cid),("redirect_uri",TE.encodeUtf8 url),("response_type","code")] + buildScopes :: [Scope] -> HT.SimpleQuery + buildScopes []=[] + buildScopes l =[("scope",BS.intercalate "+" $ map (TE.encodeUtf8 . toLower . pack . show) l)] + +-- | second step of authorization: get the access token once the user has been redirected with a code +getUserAccessTokenURL2 :: (MonadBaseControl IO m, MonadResource m) => + RedirectUri -- ^ the redirect uri + -> Text -- ^ the code sent back to your app + -> InstagramT m OAuthToken -- ^ the auth token +getUserAccessTokenURL2 url code= + addClientInfos buildQuery >>= getPostRequest "/oauth/access_token" >>= getJSONResponse + where + -- | build query parameters + buildQuery :: HT.SimpleQuery + buildQuery =[("redirect_uri",TE.encodeUtf8 url),("grant_type","authorization_code"), + ("code",TE.encodeUtf8 code)] + + + diff --git a/src/Instagram/Comments.hs b/src/Instagram/Comments.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Comments.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | comments handling +-- +module Instagram.Comments ( + getComments + ,postComment + ,deleteComment +)where + +import Instagram.Monad +import Instagram.Types + +import Data.Conduit +import qualified Network.HTTP.Types as HT +import Data.Text (Text) + +-- | Get a full list of comments on a media. +getComments :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> Maybe OAuthToken + -> InstagramT m (Envelope [Comment]) +getComments mid token =getGetEnvelopeM ["/v1/media/",mid,"/comments"] token ([]::HT.Query) + +-- | Create a comment on a media. +postComment :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> OAuthToken + -> Text + -> InstagramT m (Envelope NoResult) +postComment mid token txt =getPostEnvelope ["/v1/media/",mid,"/comments"] token ["text" ?+ txt] + +-- | Remove a comment either on the authenticated user's media or authored by the authenticated user. +deleteComment :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> CommentID + -> OAuthToken + -> InstagramT m (Envelope NoResult) +deleteComment mid cid token =getDeleteEnvelope ["/v1/media/",mid,"/comments/",cid] token ([]::HT.Query) diff --git a/src/Instagram/Geographies.hs b/src/Instagram/Geographies.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Geographies.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | geographies handling +-- +module Instagram.Geographies ( + GeographyMediaParams(..) + ,getGeographyRecentMedia +)where + +import Instagram.Monad +import Instagram.Types + +import qualified Network.HTTP.Types as HT +import qualified Data.Text as T (Text) +import Data.Conduit +import Data.Default +import Data.Typeable +import Data.Maybe (isJust) + +-- | Parameters for call to recent media in geography search +data GeographyMediaParams = GeographyMediaParams { + gmpCount :: Maybe Integer + ,gmpMinId :: Maybe T.Text + } + deriving (Show,Typeable) + +instance Default GeographyMediaParams where + def=GeographyMediaParams Nothing Nothing + +instance HT.QueryLike GeographyMediaParams where + toQuery (GeographyMediaParams cnt minI)=filter (isJust .snd) + ["count" ?+ cnt + ,"min_id" ?+ minI ] + +-- | Get very recent media from a geography subscription that you created +getGeographyRecentMedia :: (MonadBaseControl IO m, MonadResource m) => + GeographyID + -> GeographyMediaParams + ->InstagramT m (Envelope [Media]) +getGeographyRecentMedia gid = getGetEnvelopeM ["/v1/geographies/", gid,"/media/recent"] Nothing diff --git a/src/Instagram/Likes.hs b/src/Instagram/Likes.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Likes.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Likes handling +-- +module Instagram.Likes ( + getLikes + ,like + ,unlike +)where + +import Instagram.Monad +import Instagram.Types + +import Data.Conduit +import qualified Network.HTTP.Types as HT + + +-- | Get a list of users who have liked this media. +getLikes :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> Maybe OAuthToken + -> InstagramT m (Envelope [User]) +getLikes mid token =getGetEnvelopeM ["/v1/media/",mid,"/likes"] token ([]::HT.Query) + +-- | Set a like on this media by the currently authenticated user. +like :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> OAuthToken + -> InstagramT m (Envelope NoResult) +like mid token =getPostEnvelope ["/v1/media/",mid,"/likes"] token ([]::HT.Query) + +-- | Remove a like on this media by the currently authenticated user. +unlike :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> OAuthToken + -> InstagramT m (Envelope NoResult) +unlike mid token =getDeleteEnvelope ["/v1/media/",mid,"/likes"] token ([]::HT.Query) diff --git a/src/Instagram/Locations.hs b/src/Instagram/Locations.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Locations.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | locations handling +-- +module Instagram.Locations ( + getLocation + ,LocationMediaParams(..) + ,getLocationRecentMedia + ,LocationSearchParams(..) + ,searchLocations +) where + +import Instagram.Monad +import Instagram.Types + +import qualified Network.HTTP.Types as HT +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Text as T (Text) +import Data.Conduit +import Data.Typeable +import Data.Default +import Data.Maybe (isJust) + + +-- | Get information about a location. +getLocation :: (MonadBaseControl IO m, MonadResource m) => + LocationID + -> Maybe OAuthToken + ->InstagramT m (Envelope (Maybe Location)) +getLocation lid token=getGetEnvelopeM ["/v1/locations/",lid] token ([]::HT.Query) + + +-- | Parameters for call to recent media in location search +data LocationMediaParams = LocationMediaParams { + lmspMaxTimestamp :: Maybe POSIXTime, + lmspMinTimestamp :: Maybe POSIXTime, + lmspMaxID :: Maybe T.Text, + lmspMinId :: Maybe T.Text + } + deriving (Show,Typeable) + +instance Default LocationMediaParams where + def=LocationMediaParams Nothing Nothing Nothing Nothing + +instance HT.QueryLike LocationMediaParams where + toQuery (LocationMediaParams maxT minT maxI minI)=filter (isJust .snd) + ["max_timestamp" ?+ maxT + ,"min_timestamp" ?+ minT + ,"max_id" ?+ maxI + ,"min_id" ?+ minI ] + +-- | Get a list of recent media objects from a given location. +getLocationRecentMedia :: (MonadBaseControl IO m, MonadResource m) => + LocationID + -> Maybe OAuthToken + -> LocationMediaParams + ->InstagramT m (Envelope [Media]) +getLocationRecentMedia lid = getGetEnvelopeM ["/v1/locations/", lid,"/media/recent"] + + +-- | Parameters for call to media search +data LocationSearchParams = LocationSearchParams { + lspLatitude :: Maybe Double + ,lspLongitude :: Maybe Double + ,lspDistance :: Maybe Integer + ,lspFoursquareIDv2 :: Maybe T.Text + ,lspFoursquareID :: Maybe T.Text + } + deriving (Show,Typeable) + +instance Default LocationSearchParams where + def=LocationSearchParams Nothing Nothing Nothing Nothing Nothing + +instance HT.QueryLike LocationSearchParams where + toQuery (LocationSearchParams lat long dis fsidV2 fsid )=filter (isJust .snd) + ["lat" ?+ lat + ,"lng" ?+ long + ,"distance" ?+ dis + ,"foursquare_v2_id" ?+ fsidV2 + ,"foursquare_id" ?+ fsid + ] + +-- | Search for a location by geographic coordinate. +searchLocations :: (MonadBaseControl IO m, MonadResource m) => + Maybe OAuthToken + -> LocationSearchParams + ->InstagramT m (Envelope [Location]) +searchLocations = getGetEnvelopeM ["/v1/locations/search"] diff --git a/src/Instagram/Media.hs b/src/Instagram/Media.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Media.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | media handling +-- +module Instagram.Media ( + getMedia + ,getPopularMedia + ,MediaSearchParams(..) + ,searchMedia +)where + +import Instagram.Monad +import Instagram.Types + +import Data.Conduit +import qualified Network.HTTP.Types as HT +import Data.Default (Default(..)) +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Typeable (Typeable) +import Data.Maybe (isJust) + +-- | Get information about a media object. +getMedia :: (MonadBaseControl IO m, MonadResource m) => MediaID + -> Maybe OAuthToken + -> InstagramT m (Envelope (Maybe Media)) +getMedia mid token =getGetEnvelopeM ["/v1/media/",mid] token ([]::HT.Query) + +-- | Get a list of what media is most popular at the moment. +getPopularMedia :: (MonadBaseControl IO m, MonadResource m) => + Maybe OAuthToken + -> InstagramT m (Envelope [Media]) +getPopularMedia token =getGetEnvelopeM ["/v1/media/popular"] token ([]::HT.Query) + +-- | Parameters for call to media search +data MediaSearchParams = MediaSearchParams { + mspLatitude :: Maybe Double + ,mspLongitude :: Maybe Double + ,mspDistance :: Maybe Integer + ,mspMaxTimestamp :: Maybe POSIXTime + ,mspMinTimestamp :: Maybe POSIXTime + } + deriving (Show,Typeable) + +instance Default MediaSearchParams where + def=MediaSearchParams Nothing Nothing Nothing Nothing Nothing + +instance HT.QueryLike MediaSearchParams where + toQuery (MediaSearchParams lat long dis maxT minT )=filter (isJust .snd) + ["lat" ?+ lat + ,"lng" ?+ long + ,"distance" ?+ dis + ,"max_timestamp" ?+ maxT + ,"min_timestamp" ?+ minT + ] + +-- | Search for media in a given area. +searchMedia :: (MonadBaseControl IO m, MonadResource m) => + Maybe OAuthToken + -> MediaSearchParams + -> InstagramT m (Envelope [Media]) +searchMedia =getGetEnvelopeM ["/v1/media/search"] + diff --git a/src/Instagram/Monad.hs b/src/Instagram/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Monad.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleInstances, + MultiParamTypeClasses, UndecidableInstances, TypeFamilies, + FlexibleContexts, RankNTypes,CPP #-} +-- | the instagram monad stack and helper functions +module Instagram.Monad ( + InstagramT + ,runInstagramT + ,getCreds + ,getHost + ,getPostRequest + ,getGetRequest + ,getDeleteRequest + ,getQueryURL + ,getJSONResponse + ,getJSONEnvelope + ,getGetEnvelope + ,getGetEnvelopeM + ,getPostEnvelope + ,getPostEnvelopeM + ,getDeleteEnvelope + ,getDeleteEnvelopeM + ,getManager + ,runResourceInIs + ,mapInstagramT + ,addToken + ,addTokenM + ,addClientInfos + ,ToHtQuery(..) + ) where + +import Instagram.Types + +import Control.Applicative +import Control.Monad (MonadPlus, liftM) +import Control.Monad.Base (MonadBase(..)) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Class (MonadTrans(lift)) +import Control.Monad.Trans.Control ( MonadTransControl(..), MonadBaseControl(..) + , ComposeSt, defaultLiftBaseWith + , defaultRestoreM ) +import Control.Monad.Trans.Reader (ReaderT(..), ask, mapReaderT) +import Data.Typeable (Typeable) +import qualified Control.Monad.Trans.Resource as R +import qualified Control.Exception.Lifted as L + +import qualified Data.Conduit as C +import qualified Network.HTTP.Conduit as H +import qualified Network.HTTP.Types as HT +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.Aeson (json,fromJSON,Result(..),FromJSON) +import Data.Conduit.Attoparsec (sinkParser, ParseError) +import Control.Exception.Base (throw) +import qualified Data.Text.Encoding as TE +import qualified Data.Text as T (Text,concat) +import Data.Time.Clock.POSIX (POSIXTime) + +#if DEBUG +import Data.Conduit.Binary (sinkHandle) +import System.IO (stdout) +import Data.Conduit.Util (zipSinks) +#endif + +-- | the instagram monad transformer +-- this encapsulates the data necessary to pass the app credentials, etc +newtype InstagramT m a = Is { unIs :: ReaderT IsData m a } + deriving ( Functor, Applicative, Alternative, Monad + , MonadFix, MonadPlus, MonadIO, MonadTrans + , R.MonadThrow, R.MonadActive, R.MonadResource ) + +instance MonadBase b m => MonadBase b (InstagramT m) where + liftBase = lift . liftBase + +instance MonadTransControl InstagramT where + newtype StT InstagramT a = FbStT { unFbStT :: StT (ReaderT IsData) a } + liftWith f = Is $ liftWith (\run -> f (liftM FbStT . run . unIs)) + restoreT = Is . restoreT . liftM unFbStT + +instance MonadBaseControl b m => MonadBaseControl b (InstagramT m) where + newtype StM (InstagramT m) a = StMT {unStMT :: ComposeSt InstagramT m a} + liftBaseWith = defaultLiftBaseWith StMT + restoreM = defaultRestoreM unStMT + +-- | Run a computation in the 'InstagramT' monad transformer with +-- your credentials. +runInstagramT :: Credentials -- ^ Your app's credentials. + -> H.Manager -- ^ Connection manager (see 'H.withManager'). + -> InstagramT m a -- ^ the action to run + -> m a -- ^ the result +runInstagramT creds manager (Is act) = + runReaderT act (IsData creds manager "api.instagram.com") -- potentially we could open to other hosts if there were test endpoints, etc... + +-- | Get the user's credentials. +getCreds :: Monad m => InstagramT m Credentials +getCreds = isCreds `liftM` Is ask + +-- | Get the instagram host +getHost :: Monad m => InstagramT m ByteString +getHost = isHost `liftM` Is ask + +-- | build a post request to Instagram +getPostRequest :: (Monad m,HT.QueryLike q) => ByteString -- ^ the url path + -> q -- ^ the query parameters + -> InstagramT m (H.Request a) -- ^ the properly configured request +getPostRequest path query=do + host<-getHost + return $ H.def { + H.secure=True + , H.host = host + , H.port = 443 + , H.path = path + , H.method=HT.methodPost + , H.requestBody=H.RequestBodyBS $ HT.renderQuery False $ HT.toQuery query + } + +-- | build a get request to Instagram +getGetRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path + -> q -- ^ the query parameters + -> InstagramT m (H.Request a) -- ^ the properly configured request +getGetRequest path query=do + host<-getHost + let qs=HT.renderQuery True $ HT.toQuery query +#if DEBUG + liftIO $ BSC.putStrLn $ BS.append path qs +#endif + return $ H.def { + H.secure=True + , H.host = host + , H.port = 443 + , H.path = path + , H.method=HT.methodGet + , H.queryString=qs + } + +-- | build a delete request to Instagram +getDeleteRequest :: (Monad m,MonadIO m,HT.QueryLike q) => ByteString -- ^ the url path + -> q -- ^ the query parameters + -> InstagramT m (H.Request a) -- ^ the properly configured request +getDeleteRequest path query=do + get<-getGetRequest path query + return $ get {H.method=HT.methodDelete} + +-- | build a URL for a get operation with a single query +getQueryURL :: (Monad m,HT.QueryLike q) => ByteString -- ^ the url path + -> q -- ^ the query parameters + -> InstagramT m ByteString -- ^ the URL +getQueryURL path query=do + host<-getHost + return $ BS.concat ["https://",host,path,HT.renderQuery True $ HT.toQuery query] + +-- | perform a HTTP request and deal with the JSON result +igReq :: forall b (m :: * -> *) wrappedErr . + (MonadBaseControl IO m, C.MonadResource m,FromJSON b,FromJSON wrappedErr) => + H.Request (InstagramT m) + -> (wrappedErr -> IGError) -- ^ extract the error from the JSON + -> InstagramT m b +igReq req extractError=do + -- we check the status ourselves + let req' = req { H.checkStatus = \_ _ _ -> Nothing } + mgr<-getManager + res<-H.http req' mgr + let status = H.responseStatus res + headers = H.responseHeaders res + cookies = H.responseCookieJar res + ok=isOkay status + err=H.StatusCodeException status headers cookies + L.catch (do +#if DEBUG + (value,_)<-H.responseBody res C.$$+- zipSinks (sinkParser json) (sinkHandle stdout) + liftIO $ BSC.putStrLn "" +#else + value<-H.responseBody res C.$$+- sinkParser json +#endif + if ok + then + -- parse response as the expected value + case fromJSON value of + Success ot->return ot + Error jerr->throw $ JSONException jerr -- got an ok response we couldn't parse + else + -- parse response as an error + case fromJSON value of + Success ise-> throw $ IGAppException $ extractError ise + _ -> throw err -- we can't even parse the error, throw the HTTP error + ) (\(_::ParseError)->throw err) -- the error body wasn't even json + +-- | get a JSON response from a request to Instagram +-- instagram returns either a result, or an error +getJSONResponse :: forall (m :: * -> *) v. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v) => + H.Request (InstagramT m) + -> InstagramT + m v +getJSONResponse req=igReq req id + +-- | get an envelope from a request to Instagram +-- the error is wrapped inside the envelope +getJSONEnvelope :: forall (m :: * -> *) v. + (MonadBaseControl IO m, C.MonadResource m,FromJSON v) => + H.Request (InstagramT m) + -> InstagramT + m (Envelope v) +getJSONEnvelope req=igReq req eeMeta + +-- | get an envelope from Instagram +getGetEnvelope :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + [T.Text] -- ^ the URL components, will be concatenated + -> OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getGetEnvelope urlComponents token=getGetEnvelopeM urlComponents (Just token) + +-- | get an envelope from Instagram, with optional authentication +getGetEnvelopeM :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + [T.Text] -- ^ the URL components, will be concatenated + -> Maybe OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getGetEnvelopeM=getEnvelopeM getGetRequest + +-- | send a delete and get an envelope from Instagram +getDeleteEnvelope :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + [T.Text] -- ^ the URL components, will be concatenated + -> OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getDeleteEnvelope urlComponents token=getDeleteEnvelopeM urlComponents (Just token) + +-- | send a delete and get an envelope from Instagram, with optional authentication +getDeleteEnvelopeM :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + [T.Text] -- ^ the URL components, will be concatenated + -> Maybe OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getDeleteEnvelopeM=getEnvelopeM getDeleteRequest + +-- | post a request and get back an envelope from Instagram +getPostEnvelope :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + [T.Text] -- ^ the URL components, will be concatenated + -> OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getPostEnvelope urlComponents token=getPostEnvelopeM urlComponents (Just token) + +-- | post a request and get back an envelope from Instagram, with optional authentication +getPostEnvelopeM :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + [T.Text] -- ^ the URL components, will be concatenated + -> Maybe OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getPostEnvelopeM=getEnvelopeM getPostRequest + +-- | utility function to get an envelop, independently of how the request is built +getEnvelopeM :: (MonadBaseControl IO m, C.MonadResource m,HT.QueryLike ql,FromJSON v) => + (ByteString -> HT.Query -> InstagramT m (H.Request (InstagramT m))) -- ^ the request building method + -> [T.Text] -- ^ the URL components, will be concatenated + -> Maybe OAuthToken -- ^ the access token + -> ql -- ^ the query parameters + -> InstagramT m (Envelope v) -- ^ the resulting envelope +getEnvelopeM f urlComponents token ql=do + let url=TE.encodeUtf8 $ T.concat urlComponents + addTokenM token ql >>= f url >>= getJSONEnvelope + +-- | Get the 'H.Manager'. +getManager :: Monad m => InstagramT m H.Manager +getManager = isManager `liftM` Is ask + +-- | Run a 'ResourceT' inside a 'InstagramT'. +runResourceInIs :: (C.MonadResource m, MonadBaseControl IO m) => + InstagramT (C.ResourceT m) a + -> InstagramT m a +runResourceInIs (Is inner) = Is $ ask >>= lift . C.runResourceT . runReaderT inner + +-- | Transform the computation inside a 'InstagramT'. +mapInstagramT :: (m a -> n b) -> InstagramT m a -> InstagramT n b +mapInstagramT f = Is . mapReaderT f . unIs + +-- | the data kept through the computations +data IsData = IsData { + isCreds::Credentials -- ^ app credentials + ,isManager::H.Manager -- ^ HTTP connection manager + ,isHost:: ByteString -- ^ host name + } + deriving (Typeable) + +-- | @True@ if the the 'Status' is ok (i.e. @2XX@). +isOkay :: HT.Status -> Bool +isOkay status = + let sc = HT.statusCode status + in 200 <= sc && sc < 300 + +-- | add the access token to the query +addToken :: HT.QueryLike ql=> OAuthToken -> ql -> HT.Query +addToken (OAuthToken{oaAccessToken=(AccessToken t)}) ql=("access_token", Just $ TE.encodeUtf8 t) : HT.toQuery ql + +-- | add an optional access token to the query +-- if we don't have a token, we'll pass the client_id +addTokenM :: (C.MonadResource m, MonadBaseControl IO m,HT.QueryLike ql)=> Maybe OAuthToken -> ql -> InstagramT m HT.Query +addTokenM (Just oat) ql=return $ addToken oat ql +addTokenM _ ql= do + cid<-liftM clientIDBS getCreds + return $ ("client_id",Just cid) : HT.toQuery ql + +-- | add application client info to the query +addClientInfos :: (C.MonadResource m, MonadBaseControl IO m,HT.QueryLike ql) => + ql -> + InstagramT m HT.Query +addClientInfos ql= do + cid<-liftM clientIDBS getCreds + csecret<-liftM clientSecretBS getCreds + return $ ("client_id",Just cid):("client_secret", Just csecret) : HT.toQuery ql + +-- | simple class used to hide the serialization of parameters ansd simplify the calling code +class ToHtQuery a where + (?+) :: ByteString -> a -> (ByteString,Maybe ByteString) + +instance ToHtQuery Double where + n ?+ d=n ?+ show d + +instance ToHtQuery (Maybe Double) where + n ?+ d=n ?+ fmap show d + +instance ToHtQuery Integer where + n ?+ d=n ?+ show d + +instance ToHtQuery (Maybe Integer) where + n ?+ d=n ?+ fmap show d + +instance ToHtQuery (Maybe POSIXTime) where + n ?+ d=n ?+ fmap (show . (round :: POSIXTime -> Integer)) d + +instance ToHtQuery (Maybe T.Text) where + n ?+ d=(n,fmap TE.encodeUtf8 d) + +instance ToHtQuery T.Text where + n ?+ d=(n,Just $ TE.encodeUtf8 d) + +instance ToHtQuery (Maybe String) where + n ?+ d=(n,fmap BSC.pack d) + +instance ToHtQuery String where + n ?+ d=(n,Just $ BSC.pack d) + diff --git a/src/Instagram/RealTime.hs b/src/Instagram/RealTime.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/RealTime.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Real time subscription management +-- +module Instagram.RealTime ( + createSubscription + ,listSubscriptions + ,deleteSubscriptions + ,SubscriptionRequest(..) + ,SubscriptionParams(..) + ,DeletionParams(..) + ,verifySignature +) + +where + +import Instagram.Monad +import Instagram.Types + +import Data.Text (Text) +import Data.Typeable +import qualified Network.HTTP.Types as HT +import Data.Maybe (isJust) +import Data.Conduit +import Data.Aeson (Value(..)) + +import qualified Data.ByteString.Base16 as Base16 +import qualified Crypto.Classes as Crypto +import qualified Crypto.HMAC as Crypto +import Crypto.Hash.CryptoAPI (SHA1) +import Control.Monad (liftM) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +-- | create a subscription +createSubscription :: (MonadBaseControl IO m, MonadResource m) => + SubscriptionParams -- ^ the subscription parameters + -> InstagramT m (Envelope Subscription) -- ^ the created subscription +createSubscription params=do + let url="/v1/subscriptions/" + addClientInfos params >>= getPostRequest url >>= getJSONEnvelope + +-- | list all subscriptions for the application +listSubscriptions :: (MonadBaseControl IO m, MonadResource m) => + InstagramT m (Envelope [Subscription]) -- ^ the ID of the subscription +listSubscriptions =do + let url="/v1/subscriptions/" + addClientInfos ([]::HT.Query) >>= getGetRequest url >>= getJSONEnvelope + +-- | delete subscriptions based on criteria +deleteSubscriptions :: (MonadBaseControl IO m, MonadResource m) => + DeletionParams -- ^ the parameters for the deletion + -> InstagramT m (Envelope Value) -- ^ the ID of the subscription +deleteSubscriptions params=do + let url="/v1/subscriptions/" + addClientInfos params >>= getDeleteRequest url >>= getJSONEnvelope + +-- | parameters for the subscription creation +data SubscriptionParams= SubscriptionParams { + spRequest :: SubscriptionRequest -- ^ the actual subscription request + ,spCallback :: CallbackUrl -- ^ the url Instagram will post notifications to + ,spAspect :: Aspect -- ^ the subscription aspect + ,spVerifyToken :: Maybe Text -- ^ the verification token + } + deriving (Read,Show,Eq,Ord,Typeable) + +-- | to HTTP query +instance HT.QueryLike SubscriptionParams where + toQuery (SubscriptionParams req cb (Aspect asp) tok)=filter (isJust .snd) $ HT.toQuery req ++ + ["aspect" ?+ asp + ,"callback_url" ?+ cb + ,"verify_token" ?+ tok] + +-- | details of subscription request +data SubscriptionRequest + -- | when a user uploads a picture + =UserRequest + -- | when a picture is tagged with the given tag + | TagRequest { + trTag ::Text + } + -- | when a picture is tagged with a specific location + | LocationRequest { + lrID :: Text +  } + -- | when a picture is tagged with a location inside the given region + | GeographyRequest { + grLatitude :: Double + ,grLongitude :: Double + ,grRadius :: Integer + } + deriving (Read,Show,Eq,Ord,Typeable) + +-- | to HTTP query +instance HT.QueryLike SubscriptionRequest where + toQuery UserRequest=[("object",Just "user")] + toQuery (TagRequest tag)=[("object",Just "tag"),"object_id" ?+ tag] + toQuery (LocationRequest i)=[("object",Just "location"),"object_id" ?+ i] + toQuery (GeographyRequest lat lng rad)=[("object",Just "geography"),"lat" ?+ lat + ,"lng" ?+ lng + ,"radius" ?+ rad] + +-- | deletion parameters +data DeletionParams + -- | delete all subscriptions + =DeleteAll + -- | delete one subscription, given its ID + | DeleteOne { + doID :: Text + } + -- | delete all user subscriptions + | DeleteUsers + -- | delete all tag subscriptions + | DeleteTags + -- | delete all location subscriptions + | DeleteLocations + -- | delete all geography subscriptions + | DeleteGeographies + deriving (Read,Show,Eq,Ord,Typeable) + +-- | to HTTP query +instance HT.QueryLike DeletionParams where + toQuery DeleteAll=[("object",Just "all")] + toQuery (DeleteOne i)=["id" ?+ i] + toQuery DeleteUsers=[("object",Just "user")] + toQuery DeleteTags=[("object",Just "tag")] + toQuery DeleteLocations=[("object",Just "location")] + toQuery DeleteGeographies=[("object",Just "geography")] + +-- | verify the signature with the content, using the secret as the key +verifySignature :: Monad m => + BS.ByteString -- ^ the signature + -> BSL.ByteString -- ^ the content + -> InstagramT m Bool +verifySignature sig content=do + csecret<-liftM clientSecretBS getCreds + let key :: Crypto.MacKey ctx SHA1 + key = Crypto.MacKey csecret -- secret is the key + hash = Crypto.hmac key content + expected = Base16.encode (Crypto.encode hash) + return $! sig `Crypto.constTimeEq` expected diff --git a/src/Instagram/Relationships.hs b/src/Instagram/Relationships.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Relationships.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | relationship handling +-- +module Instagram.Relationships ( + getFollows + ,getFollowedBy + ,getRequestedBy + ,getRelationship + ,setRelationShip + ,RelationShipAction(..) +)where + +import Instagram.Monad +import Instagram.Types + +import Data.Typeable (Typeable) + +import qualified Network.HTTP.Types as HT +import Data.Conduit +import Data.Char (toLower) + + +-- | Get the list of users this user follows. +getFollows :: (MonadBaseControl IO m, MonadResource m) => UserID + -> Maybe OAuthToken + -> InstagramT m (Envelope [User]) +getFollows uid token =getGetEnvelopeM ["/v1/users/",uid,"/follows"] token ([]::HT.Query) + +-- | Get the list of users this user is followed by. +getFollowedBy :: (MonadBaseControl IO m, MonadResource m) => UserID + -> Maybe OAuthToken + -> InstagramT m (Envelope [User]) +getFollowedBy uid token =getGetEnvelopeM ["/v1/users/",uid,"/followed-by"] token ([]::HT.Query) + +-- | List the users who have requested this user's permission to follow. +getRequestedBy :: (MonadBaseControl IO m, MonadResource m) => + OAuthToken + -> InstagramT m (Envelope [User]) +getRequestedBy token =getGetEnvelope ["/v1/users/self/requested-by"] token ([]::HT.Query) + +-- | Get information about a relationship to another user. +getRelationship :: (MonadBaseControl IO m, MonadResource m) => UserID + -> OAuthToken + -> InstagramT m (Envelope Relationship) +getRelationship uid token =getGetEnvelope ["/v1/users/",uid,"/relationship"] token ([]::HT.Query) + +-- | relationship action +data RelationShipAction = Follow + | Unfollow + | Block + | Unblock + | Approve + | Deny + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +instance HT.QueryLike RelationShipAction where + toQuery a= + ["action" ?+ map toLower (show a)] + +-- | Modify the relationship between the current user and the target user. +setRelationShip :: (MonadBaseControl IO m, MonadResource m) => UserID + -> OAuthToken + -> RelationShipAction + -> InstagramT m (Envelope Relationship) +setRelationShip uid=getPostEnvelope ["/v1/users/",uid,"/relationship"] diff --git a/src/Instagram/Tags.hs b/src/Instagram/Tags.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Tags.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | tag operations +-- +module Instagram.Tags ( + getTag + ,RecentTagParams(..) + ,getRecentTagged + ,searchTags +)where + +import Instagram.Monad +import Instagram.Types + +import qualified Network.HTTP.Types as HT + +import qualified Data.Text as T (Text) +import Data.Conduit +import Data.Typeable +import Data.Default +import Data.Maybe (isJust) + +-- | Get information about a tag object. +getTag :: (MonadBaseControl IO m, MonadResource m) => + TagName + -> Maybe OAuthToken + ->InstagramT m (Envelope (Maybe Tag)) +getTag name token=getGetEnvelopeM ["/v1/tags/",name] token ([]::HT.Query) + +-- | Get a list of recently tagged media. +getRecentTagged :: (MonadBaseControl IO m, MonadResource m) => + TagName + -> Maybe OAuthToken + -> RecentTagParams + ->InstagramT m (Envelope [Media]) +getRecentTagged name=getGetEnvelopeM ["/v1/tags/",name,"/media/recent/"] + +-- | Search for tags by name. +searchTags :: (MonadBaseControl IO m, MonadResource m) => + TagName + -> Maybe OAuthToken + ->InstagramT m (Envelope [Tag]) +searchTags name token=getGetEnvelopeM ["/v1/tags/search"] token ["q" ?+ name] + +-- | parameters for recent tag pagination +data RecentTagParams=RecentTagParams{ + rtpMaxID :: Maybe T.Text + ,rtpMinID :: Maybe T.Text + }deriving (Show,Typeable) + +instance Default RecentTagParams where + def=RecentTagParams Nothing Nothing + +instance HT.QueryLike RecentTagParams where + toQuery (RecentTagParams maxI minI)=filter (isJust .snd) + ["max_tag_id" ?+ maxI + ,"min_tag_id" ?+ minI] + diff --git a/src/Instagram/Types.hs b/src/Instagram/Types.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Types.hs @@ -0,0 +1,607 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-} +-- | Types definitions +module Instagram.Types ( + Credentials(..) + ,clientIDBS + ,clientSecretBS + ,OAuthToken(..) + ,AccessToken(..) + ,UserID + ,User(..) + ,Scope(..) + ,IGException(..) + ,Envelope(..) + ,ErrEnvelope(..) + ,IGError + ,Pagination(..) + ,MediaID + ,Media(..) + ,Position(..) + ,UserPosition(..) + ,LocationID + ,Location(..) + ,ImageData(..) + ,Images(..) + ,CommentID + ,Comment(..) + ,Collection(..) + ,Aspect(..) + ,media + ,CallbackUrl + ,Subscription(..) + ,Update(..) + ,TagName + ,Tag(..) + ,OutgoingStatus(..) + ,IncomingStatus(..) + ,Relationship(..) + ,NoResult + ,GeographyID +)where + +import Control.Applicative +import Data.Text +import Data.Typeable (Typeable) +import Data.ByteString (ByteString) + +import Data.Aeson + + +import qualified Data.Text.Encoding as TE +import Control.Exception.Base (Exception) +import Data.Time.Clock.POSIX (POSIXTime) +import qualified Data.Text as T (pack) +import Data.Aeson.Types (Parser) +import qualified Data.HashMap.Strict as HM (lookup) + +-- | the app credentials +data Credentials = Credentials { + cClientID :: Text -- ^ client id + ,cClientSecret :: Text -- ^ client secret + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | get client id in ByteString form +clientIDBS :: Credentials -> ByteString +clientIDBS=TE.encodeUtf8 . cClientID + +-- | get client secret in ByteString form +clientSecretBS :: Credentials -> ByteString +clientSecretBS=TE.encodeUtf8 . cClientSecret + +-- | the oauth token returned after authentication +data OAuthToken = OAuthToken { + oaAccessToken :: AccessToken -- ^ the access token + ,oaUser :: User -- ^ the user structure returned + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON OAuthToken where + toJSON oa=object ["access_token" .= oaAccessToken oa, "user" .= oaUser oa] + +-- | from json as per Instagram format +instance FromJSON OAuthToken where + parseJSON (Object v) =OAuthToken <$> + v .: "access_token" <*> + v .: "user" + parseJSON _= fail "OAuthToken" + +-- | the access token is simply a Text +newtype AccessToken=AccessToken Text + deriving (Eq, Ord, Read, Show, Typeable) + +-- | simple string +instance ToJSON AccessToken where + toJSON (AccessToken at)=String at + +-- | simple string +instance FromJSON AccessToken where + parseJSON (String s)=pure $ AccessToken s + parseJSON _= fail "AccessToken" + +-- | User ID +type UserID = Text + +-- | the User partial profile returned by the authentication +data User = User { + uID :: UserID, + uUsername :: Text, + uFullName :: Text, + uProfilePicture :: Maybe Text, + uWebsite :: Maybe Text + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON User where + toJSON u=object ["id" .= uID u, "username" .= uUsername u , "full_name" .= uFullName u, "profile_picture" .= uProfilePicture u, "website" .= uWebsite u] + +-- | from json as per Instagram format +instance FromJSON User where + parseJSON (Object v) =User <$> + v .: "id" <*> + v .: "username" <*> + v .: "full_name" <*> + v .:? "profile_picture" <*> + v .:? "website" + parseJSON _= fail "User" + +-- | the scopes of the authentication +data Scope=Basic | Comments | Relationships | Likes + deriving (Show,Read,Eq,Ord,Enum,Bounded,Typeable) + +-- | an error returned to us by Instagram +data IGError = IGError { + igeCode :: Int + ,igeType :: Maybe Text + ,igeMessage :: Maybe Text + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON IGError where + toJSON e=object ["code" .= igeCode e, "error_type" .= igeType e , "error_message" .= igeMessage e] + +-- | from json as per Instagram format +instance FromJSON IGError where + parseJSON (Object v) =IGError <$> + v .: "code" <*> + v .:? "error_type" <*> + v .:? "error_message" + parseJSON _= fail "IGError" + +-- | an exception that a call to instagram may throw +data IGException = JSONException String -- ^ JSON parsingError + | IGAppException IGError -- ^ application exception + deriving (Show,Typeable) + +-- | make our exception type a normal exception +instance Exception IGException + +-- | envelope for Instagram OK response +data Envelope d=Envelope{ + eMeta :: IGError -- ^ this should only say 200, no error, but put here for completeness + ,eData :: d -- ^ data, garanteed to be present (otherwise we get an ErrEnvelope) + ,ePagination :: Maybe Pagination + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance (ToJSON d)=>ToJSON (Envelope d) where + toJSON e=object ["meta" .= eMeta e, "data" .= eData e, "pagination" .= ePagination e] + +-- | from json as per Instagram format +instance (FromJSON d)=>FromJSON (Envelope d) where + parseJSON (Object v) =Envelope <$> + v .: "meta" <*> + v .: "data" <*> + v .:? "pagination" + parseJSON _= fail "Envelope" + +-- | error envelope for Instagram error response +data ErrEnvelope=ErrEnvelope{ + eeMeta :: IGError + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON ErrEnvelope where + toJSON e=object ["meta" .= eeMeta e] + +-- | from json as per Instagram format +instance FromJSON ErrEnvelope where + parseJSON (Object v) =ErrEnvelope <$> + v .: "meta" + parseJSON _= fail "ErrEnvelope" + +-- | pagination info for responses that can return a lot of data +data Pagination = Pagination { + pNextUrl :: Maybe Text + ,pNextMaxID :: Maybe Text + ,pNextMinID :: Maybe Text + ,pNextMaxTagID :: Maybe Text + ,pMinTagID :: Maybe Text + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON Pagination where + toJSON p=object ["next_url" .= pNextUrl p, "next_max_id" .= pNextMaxID p, "next_min_id" .= pNextMinID p, "next_max_tag_id" .= pNextMaxTagID p,"min_tag_id" .= pMinTagID p] + +-- | from json as per Instagram format +instance FromJSON Pagination where + parseJSON (Object v) =Pagination <$> + v .:? "next_url" <*> + v .:? "next_max_id" <*> + v .:? "next_min_id" <*> + v .:? "next_max_tag_id" <*> + v .:? "min_tag_id" + parseJSON _= fail "Pagination" + +-- | Media ID +type MediaID=Text + +-- | instagram media object +data Media = Media { + mID :: MediaID + ,mCaption :: Maybe Comment + ,mLink :: Text + ,mUser :: User + ,mCreated :: POSIXTime + ,mImages :: Images + ,mType :: Text + ,mUsersInPhoto :: [UserPosition] + ,mFilter :: Maybe Text + ,mTags :: [Text] + ,mLocation :: Maybe Location + ,mComments :: Collection Comment + ,mLikes :: Collection User + ,mUserHasLiked :: Bool + ,mAttribution :: Maybe Object -- ^ seems to be open format https://groups.google.com/forum/?fromgroups#!topic/instagram-api-developers/KvGH1cnjljQ + } + deriving (Show,Eq,Typeable) + +-- | to json as per Instagram format +instance ToJSON Media where + toJSON m=object ["id" .= mID m,"caption" .= mCaption m,"user".= mUser m,"link" .= mLink m, "created_time" .= toJSON (show ((round $ mCreated m) :: Integer)) + ,"images" .= mImages m,"type" .= mType m,"users_in_photo" .= mUsersInPhoto m, "filter" .= mFilter m,"tags" .= mTags m + ,"location" .= mLocation m,"comments" .= mComments m,"likes" .= mLikes m,"user_has_liked" .= mUserHasLiked m,"attribution" .= mAttribution m] + +-- | from json as per Instagram format +instance FromJSON Media where + parseJSON (Object v) =do + ct::String<-v .: "created_time" + Media <$> + v .: "id" <*> + v .:? "caption" <*> + v .: "link" <*> + v .: "user" <*> + pure (fromIntegral (read ct::Integer)) <*> + v .: "images" <*> + v .: "type" <*> + v .: "users_in_photo" <*> + v .:? "filter" <*> + v .: "tags" <*> + v .:? "location" <*> + v .:? "comments" .!= Collection 0 [] <*> + v .:? "likes" .!= Collection 0 [] <*> + v .:? "user_has_liked" .!= False <*> + v .:? "attribution" + parseJSON _= fail "Media" + +-- | position in picture +data Position = Position { + pX ::Double + ,pY :: Double +} deriving (Show,Eq,Typeable) + + +-- | to json as per Instagram format +instance ToJSON Position where + toJSON p=object ["x" .= pX p,"y" .= pY p] + +-- | from json as per Instagram format +instance FromJSON Position where + parseJSON (Object v) = Position <$> + v .: "x" <*> + v .: "y" + parseJSON _=fail "Position" + +-- | position of a user +data UserPosition = UserPosition { + upPosition :: Position + ,upUser :: User + } deriving (Show,Eq,Typeable) + + +-- | to json as per Instagram format +instance ToJSON UserPosition where + toJSON p=object ["position" .= upPosition p,"user" .= upUser p] + +-- | from json as per Instagram format +instance FromJSON UserPosition where + parseJSON (Object v) = UserPosition <$> + v .: "position" <*> + v .: "user" + parseJSON _=fail "UserPosition" + +-- | location ID +type LocationID = Text + +-- | geographical location info +data Location = Location { + lID :: Maybe LocationID + ,lLatitude :: Maybe Double + ,lLongitude :: Maybe Double + ,lStreetAddress :: Maybe Text + ,lName :: Maybe Text + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON Location where + toJSON l=object ["id" .= lID l,"latitude" .= lLatitude l,"longitude" .= lLongitude l, "street_address" .= lStreetAddress l,"name" .= lName l] + +-- | from json as per Instagram format +instance FromJSON Location where + parseJSON (Object v) = + Location <$> + parseID v <*> + v .:? "latitude" <*> + v .:? "longitude" <*> + v .:? "street_address" <*> + v .:? "name" + where + -- | the Instagram API hasn't made its mind up, sometimes location id is an int, sometimes a string + parseID :: Object -> Parser (Maybe LocationID) + parseID obj=case HM.lookup "id" obj of + Just (String s)->pure $ Just s + Just (Number n)->pure $ Just $ T.pack $ show n + Nothing->pure Nothing + _->fail "LocationID" + parseJSON _= fail "Location" + +-- | data for a single image +data ImageData = ImageData { + idURL :: Text, + idWidth :: Integer, + idHeight :: Integer + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON ImageData where + toJSON i=object ["url" .= idURL i,"width" .= idWidth i,"height" .= idHeight i] + +-- | from json as per Instagram format +instance FromJSON ImageData where + parseJSON (Object v) = ImageData <$> + v .: "url" <*> + v .: "width" <*> + v .: "height" + parseJSON _= fail "ImageData" + +-- | different images for the same media +data Images = Images { + iLowRes :: ImageData + ,iThumbnail :: ImageData + ,iStandardRes :: ImageData + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON Images where + toJSON i=object ["low_resolution" .= iLowRes i,"thumbnail" .= iThumbnail i,"standard_resolution" .= iStandardRes i] + +-- | from json as per Instagram format +instance FromJSON Images where + parseJSON (Object v) = Images <$> + v .: "low_resolution" <*> + v .: "thumbnail" <*> + v .: "standard_resolution" + parseJSON _= fail "Images" + +-- | comment id +type CommentID = Text + +-- | Commenton on a medium +data Comment = Comment { + cID :: CommentID + ,cCreated :: POSIXTime + ,cText :: Text + ,cFrom :: User + } + deriving (Show,Eq,Ord,Typeable) + +-- | to json asCommentstagram format +instance ToJSON Comment where + toJSON c=object ["id" .= cID c,"created_time" .= toJSON (show ((round $ cCreated c) :: Integer)) + ,"text" .= cText c,"from" .= cFrom c] + +-- | from json asCommentstagram format +instance FromJSON Comment where + parseJSON (Object v) =do + ct::String<-v .: "created_time" + Comment <$> + v .: "id" <*> + pure (fromIntegral (read ct::Integer)) <*> + v .: "text" <*> + v .: "from" + parseJSON _= fail "Caption" + +-- | a collection of items (count + data) +-- data can only be a subset +data Collection a= Collection { + cCount :: Integer + ,cData :: [a] + } + deriving (Show,Eq,Ord,Typeable) + + +-- | to json as per Instagram format +instance (ToJSON a)=>ToJSON (Collection a) where + toJSON igc=object ["count" .= cCount igc,"data" .= cData igc] + +-- | from json as per Instagram format +instance (FromJSON a)=>FromJSON (Collection a) where + parseJSON (Object v) = Collection <$> + v .: "count" <*> + v .: "data" + parseJSON _= fail "Collection" + + +-- | the URL to receive notifications to +type CallbackUrl = Text + +-- | notification aspect +data Aspect = Aspect Text + deriving (Show, Read, Eq, Ord, Typeable) + +-- | to json as per Instagram format +instance ToJSON Aspect where + toJSON (Aspect t)=String t + +-- | from json as per Instagram format +instance FromJSON Aspect where + parseJSON (String t) = pure $ Aspect t + parseJSON _= fail "Aspect" + +-- | the media Aspect, the only one supported for now +media :: Aspect +media = Aspect "media" + +-- | a subscription to a real time notification +data Subscription= Subscription { + sID :: Text + ,sType :: Text + ,sObject :: Text + ,sObjectID :: Maybe Text + ,sAspect :: Aspect + ,sCallbackUrl :: CallbackUrl + ,sLatitude :: Maybe Double + ,sLongitude :: Maybe Double + ,sRadius :: Maybe Integer + } + deriving (Show,Eq,Typeable) + +-- | to json as per Instagram format +instance ToJSON Subscription where + toJSON s=object ["id" .= sID s,"type" .= sType s,"object" .= sObject s,"object_id" .= sObjectID s,"aspect" .= sAspect s + ,"callback_url".=sCallbackUrl s,"lat".= sLatitude s,"lng".=sLongitude s,"radius".=sRadius s] + +-- | from json as per Instagram format +instance FromJSON Subscription where + parseJSON (Object v) = Subscription <$> + v .: "id" <*> + v .: "type" <*> + v .: "object" <*> + v .:? "object_id" <*> + v .: "aspect" <*> + v .: "callback_url" <*> + v .:? "lat" <*> + v .:? "lng" <*> + v .:? "radius" + parseJSON _= fail "Subscription" + +-- | an update from a subscription +data Update = Update { + uSubscriptionID :: Integer + ,uObject :: Text + ,uObjectID :: Text + ,uChangedAspect :: Aspect + ,uTime :: POSIXTime + } + deriving (Show,Eq,Typeable) + +-- | to json as per Instagram format +instance ToJSON Update where + toJSON u=object ["subscription_id" .= uSubscriptionID u ,"object" .= uObject u,"object_id" .= uObjectID u + ,"changed_aspect" .= uChangedAspect u,"time" .= toJSON ((round $ uTime u) :: Integer)] + +-- | from json as per Instagram format +instance FromJSON Update where + parseJSON (Object v) =do + ct::Integer<-v .: "time" + Update <$> + v .: "subscription_id" <*> + v .: "object" <*> + v .: "object_id" <*> + v .: "changed_aspect" <*> + pure (fromIntegral ct) + parseJSON _= fail "Update" + +-- | Tag Name +type TagName = Text + +-- | a Tag +data Tag = Tag { + tName :: TagName, + tMediaCount :: Integer + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON Tag where + toJSON t=object ["name" .= tName t,"media_count" .= tMediaCount t] + +-- | from json as per Instagram format +instance FromJSON Tag where + parseJSON (Object v) = Tag <$> + v .: "name" <*> + v .:? "media_count" .!= 0 + parseJSON _= fail "Tag" + +-- | outgoing relationship status +data OutgoingStatus = Follows | Requested | OutNone + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per Instagram format +instance ToJSON OutgoingStatus where + toJSON Follows = String "follows" + toJSON Requested = String "requested" + toJSON OutNone = String "none" + +-- | from json as per Instagram format +instance FromJSON OutgoingStatus where + parseJSON (String "follows")=pure Follows + parseJSON (String "requested")=pure Requested + parseJSON (String "none")=pure OutNone + parseJSON _= fail "OutgoingStatus" + +-- | incoming relationship status +data IncomingStatus = FollowedBy | RequestedBy | BlockedByYou | InNone + deriving (Show,Read,Eq,Ord,Bounded,Enum,Typeable) + +-- | to json as per Instagram format +instance ToJSON IncomingStatus where + toJSON FollowedBy = String "followed_by" + toJSON RequestedBy = String "requested_by" + toJSON BlockedByYou = String "blocked_by_you" + toJSON InNone = String "none" + +-- | from json as per Instagram format +instance FromJSON IncomingStatus where + parseJSON (String "followed_by")=pure FollowedBy + parseJSON (String "requested_by")=pure RequestedBy + parseJSON (String "blocked_by_you")=pure BlockedByYou + parseJSON (String "none")=pure InNone + parseJSON _= fail "IncomingStatus" + +-- | a relationship between two users +data Relationship = Relationship { + rOutgoing :: OutgoingStatus + ,rIncoming :: IncomingStatus + ,rTargetUserPrivate :: Bool -- ^ not present in doc + } + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON Relationship where + toJSON r=object ["outgoing_status" .= rOutgoing r,"incoming_status" .= rIncoming r,"target_user_is_private" .= rTargetUserPrivate r] + +-- | from json as per Instagram format +instance FromJSON Relationship where + parseJSON (Object v) = Relationship <$> + v .:? "outgoing_status" .!= OutNone <*> + v .:? "incoming_status" .!= InNone <*> + v .:? "target_user_is_private" .!= False + parseJSON _= fail "Relationship" + +-- | Instagram returns data:null for nothing, but Aeson considers that () maps to an empty array... +-- so we model the fact that we expect null via NoResult +data NoResult = NoResult + deriving (Show,Read,Eq,Ord,Typeable) + +-- | to json as per Instagram format +instance ToJSON NoResult where + toJSON _=Null + +-- | from json as per Instagram format +instance FromJSON NoResult where + parseJSON Null = pure NoResult + parseJSON _= fail "NoResult" + +-- | geography ID +type GeographyID = Text + diff --git a/src/Instagram/Users.hs b/src/Instagram/Users.hs new file mode 100644 --- /dev/null +++ b/src/Instagram/Users.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Users end point handling +-- +module Instagram.Users ( + getUser + ,SelfFeedParams(..) + ,getSelfFeed + ,RecentParams(..) + ,getRecent + ,SelfLikedParams(..) + ,getSelfLiked + ,UserSearchParams(..) + ,searchUsers +) where + +import Instagram.Monad +import Instagram.Types + +import Data.Time.Clock.POSIX (POSIXTime) +import Data.Typeable (Typeable) + +import qualified Network.HTTP.Types as HT +import Data.Maybe (isJust) +import qualified Data.Text as T (Text) +import Data.Conduit +import Data.Default + + + +-- | Get basic information about a user. +getUser :: (MonadBaseControl IO m, MonadResource m) => UserID + -> Maybe OAuthToken + -> InstagramT m (Envelope (Maybe User)) +getUser uid token =getGetEnvelopeM ["/v1/users/",uid] token ([]::HT.Query) + +-- | Parameters for call to self feed +data SelfFeedParams = SelfFeedParams { + sfpCount :: Maybe Integer, + sfpMaxID :: Maybe T.Text, + sfpMinId :: Maybe T.Text + } + deriving (Show,Typeable) + +instance Default SelfFeedParams where + def=SelfFeedParams Nothing Nothing Nothing + +instance HT.QueryLike SelfFeedParams where + toQuery (SelfFeedParams c maxI minI)=filter (isJust .snd) + ["count" ?+ c + ,"max_id" ?+ maxI + ,"min_id" ?+ minI] + + +-- | See the authenticated user's feed. +getSelfFeed :: (MonadBaseControl IO m, MonadResource m) => + OAuthToken + -> SelfFeedParams + -> InstagramT m (Envelope [Media]) +getSelfFeed =getGetEnvelope ["/v1/users/self/feed/"] + +-- | Parameters for call to recent media +data RecentParams = RecentParams { + rpCount :: Maybe Integer, + rpMaxTimestamp :: Maybe POSIXTime, + rpMinTimestamp :: Maybe POSIXTime, + rpMaxID :: Maybe T.Text, + rpMinId :: Maybe T.Text + } + deriving (Show,Typeable) + +instance Default RecentParams where + def=RecentParams Nothing Nothing Nothing Nothing Nothing + +instance HT.QueryLike RecentParams where + toQuery (RecentParams c maxT minT maxI minI)=filter (isJust .snd) + ["count" ?+ c + ,"max_timestamp" ?+ maxT + ,"min_timestamp" ?+ minT + ,"max_id" ?+ maxI + ,"min_id" ?+ minI] + + +-- | Get the most recent media published by a user. +getRecent :: (MonadBaseControl IO m, MonadResource m) => UserID + -> OAuthToken + -> RecentParams + -> InstagramT m (Envelope [Media]) +getRecent uid=getGetEnvelope ["/v1/users/",uid,"/media/recent/"] + +-- | parameters for self liked call +data SelfLikedParams = SelfLikedParams { + slpCount :: Maybe Integer, + slpMaxLikeID :: Maybe T.Text + } + deriving (Show,Typeable) + +instance Default SelfLikedParams where + def=SelfLikedParams Nothing Nothing + +instance HT.QueryLike SelfLikedParams where + toQuery (SelfLikedParams c maxI)=filter (isJust .snd) + ["count" ?+ c + ,"max_like_id" ?+ maxI] + +-- | See the authenticated user's list of media they've liked. +getSelfLiked :: (MonadBaseControl IO m, MonadResource m) => OAuthToken + -> SelfLikedParams + -> InstagramT m (Envelope [Media]) +getSelfLiked =getGetEnvelope ["/v1/users/self/media/liked"] + +-- | parameters for self liked call +data UserSearchParams = UserSearchParams { + uspQuery :: T.Text, + uspCount :: Maybe Integer + } + deriving (Show,Typeable) + +instance HT.QueryLike UserSearchParams where + toQuery (UserSearchParams q c )=filter (isJust .snd) + ["count" ?+ c -- does not seem to be taken into account... + ,"q" ?+ q] + +-- | Search for a user by name. +searchUsers :: (MonadBaseControl IO m, MonadResource m) => Maybe OAuthToken + -> UserSearchParams + -> InstagramT m (Envelope [User]) +searchUsers =getGetEnvelopeM ["/v1/users/search"]