atndapi (empty) → 0.1.0.0
raw patch · 7 files changed
+461/−0 lines, 7 filesdep +QuickCheckdep +aesondep +atndapisetup-changed
Dependencies added: QuickCheck, aeson, atndapi, base, bytestring, conduit, data-default, hspec, http-conduit, http-types, lifted-base, monad-control, monad-logger, mtl, parsec, resourcet, text, time, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- atndapi.cabal +68/−0
- src/Web/ATND.hs +133/−0
- src/Web/ATND/Event.hs +154/−0
- src/Web/ATND/Util.hs +73/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2016++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 Author name here 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ atndapi.cabal view
@@ -0,0 +1,68 @@+name: atndapi+version: 0.1.0.0+synopsis: An interface of ATND API+description: Please see README.md+homepage: http://github.com/ynishi/atndapi#readme+license: BSD3+license-file: LICENSE+author: Yutaka Nishimura +maintainer: ytk.nishimura@gmail.com+copyright: 2016 Yutaka Nishimura +category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Web.ATND+ Web.ATND.Event+ Web.ATND.Util+ build-depends: base >= 4.7 && < 5+ , text+ , mtl+ , aeson+ , monad-control+ , monad-logger+ , parsec+ , lifted-base+ , transformers+ , data-default+ , bytestring+ , conduit+ , http-conduit+ , http-types+ , resourcet+ , time+ default-language: Haskell2010++test-suite atndapi-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , atndapi+ , text+ , mtl+ , aeson+ , monad-control+ , monad-logger+ , parsec+ , lifted-base+ , transformers+ , data-default+ , bytestring+ , conduit+ , http-conduit+ , http-types+ , resourcet+ , time+ , hspec+ , QuickCheck+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/ynishi/atndapi
+ src/Web/ATND.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+--+-- Module for interface of the ATND JSON API.+--+-- Example usage to get events (in IO monad):+-- +-- > cfg <- defaultATNDConfig+-- > runATND cfg $ do+-- > getEvents <[eventId]> <[keywords]> ... Nothing ...+-- > +-- +-- To run in a monad that implements MonadIO, MonadLogger and+-- MonadBaseControl IO (such as a Yesod Handler), use ATNDM.+--+module Web.ATND + (+ -- * The ATND/ATNDT monad + ATND,+ ATNDT,+ runATND,+ runATNDT,+ -- * Running query+ query,+ query',+ -- * Config+ ATNDConfig(..),+ defaultATNDConfig,+ -- * Error Handling+ ATNDError + ) where++import Web.ATND.Util++import Data.Text(Text, unpack, pack)+import qualified Data.Text as D (concat)+import Data.Typeable++import Data.Aeson (decode, Value(..), FromJSON(..), (.:))++import Control.Monad (mzero)+import Control.Monad.IO.Class (liftIO, MonadIO)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import Network.HTTP.Conduit (HttpException(..), setQueryString, tlsManagerSettings, parseUrl, newManager, httpLbs, Response(..), Request(..), Manager)+import Network.HTTP.Types.Header (ResponseHeaders)+import Control.Monad.Reader (runReaderT, ReaderT)+import Control.Monad.Logger+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Exception.Lifted as CEL++-- | Represent the config for ATND/ATNDT+data ATNDConfig = ATNDConfig { atndManager :: Manager }++-- | Create a ATNDConfig with a new Manager+defaultATNDConfig :: MonadIO m => m ATNDConfig+defaultATNDConfig = do+ man <- liftIO $ newManager tlsManagerSettings+ return ATNDConfig { atndManager = man }++-- | ATND monad transformer+type ATNDT m a = (MonadIO m, MonadLogger m, MonadBaseControl IO m) => ReaderT ATNDConfig m a++-- | Run ATNDT+runATNDT :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) => ATNDConfig -> ATNDT m a -> m a+runATNDT config action =+ runReaderT action config++-- | Alias of ATNDT with Logging +type ATND a = ATNDT(LoggingT IO) a ++-- | Run ATND in IO, ignoring the existing monadic context and logging to stderr.+runATND :: (MonadIO m) => + (ATNDConfig -> ATNDT(LoggingT IO) a -> m a)+runATND config action =+ liftIO $ runStderrLoggingT $ runATNDT config action++-- | Build the ATND endpoint URL+-- make https://api.atnd.org/events/[usres]+endpointUrl :: Section -> Text+endpointUrl a = D.concat ["https://api.atnd.org/", fromSection a] ++-- | Run a query to ATND. Remove Nothing in the query list. +query :: (FromJSON x) => Section + -- ^ ATND api type+ -> [(B8.ByteString, Maybe B8.ByteString)] + -- ^ List for Query String + -> ATNDT m x+query section queryList = do+ query' section $ filterQuery queryList ++-- | Run a query to ATND, for apply query list directry.+query' :: (FromJSON x) => Section -> [(B8.ByteString, Maybe B8.ByteString)] -> ATNDT m x+query' section queryList = do + config <- defaultATNDConfig + initReq <- liftIO $ parseUrl $ unpack $ endpointUrl section + let req = setQueryString queryList $ initReq+ $(logDebug) $ pack . show $ queryString req + response <- CEL.catch (httpLbs req $ atndManager config) catchHttpException+ $(logDebug) $ pack . show $ responseBody response + case decode $ responseBody response of+ Just eventResults -> return eventResults+ Nothing -> throwIO $ OtherATNDError (-1) "Parse Error: Could not parse result JSON from ATND"+ where+ catchHttpException :: HttpException -> ATNDT m a+ catchHttpException e@(StatusCodeException _ headers _) = do+ $(logDebug) $ pack . show $ lookup "X-Response-Boby-Start" headers + maybe (throwIO e) throwIO (decodeError headers)+ catchHttpException e = throwIO e+ decodeError :: ResponseHeaders -> Maybe ATNDError+ decodeError headers = BL.fromStrict `fmap` lookup "X-Response-Body-Start" headers >>= decode++-- | Error of ATND API+data ATNDError = NotFoundError Int Text+ | OtherATNDError Int Text+ deriving (Typeable, Show, Eq)++instance Exception ATNDError++instance FromJSON ATNDError where+ parseJSON (Object v) = do+ status <- v .: "status"+ message <- v .: "error"+ return $ (errConstructor status) ((read $ unpack status)::Int) message+ where+ errConstructor status = case (status :: Text) of+ "404" -> NotFoundError+ _ -> OtherATNDError+ parseJSON _ = mzero
+ src/Web/ATND/Event.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Implements the \"events\" section of the ATND JSON API.+--+module Web.ATND.Event+ (+ -- * API Method + getEvents,+ -- * Parameter type+ EventId(..),+ -- * Result type+ Events(..),+ Event(..),+ )+ where++import Web.ATND+import Web.ATND.Util++import Data.Text (Text, pack)+import Data.Aeson (Value(..), object, (.=), ToJSON(..), FromJSON(..), (.:), (.:?), Value(..))+import Control.Monad (mzero)++-- | Represent an event id+newtype EventId = EventId { unEventId :: Integer }+ deriving (Show, Eq)++-- | Represent events +newtype Events = Events { events :: [Event] }+ deriving (Show, Eq)++-- | Represent an event +data Event = Event { + eventId :: EventId, + title :: Text,+ catch :: Maybe Text,+ description :: Text,+ eventUrl :: Text,+ startedAt :: ATNDTime,+ endedAt :: ATNDTime,+ url :: Maybe Text,+ limit :: Integer,+ address :: Text,+ place :: Text,+ lat :: Text,+ lon :: Text,+ owner :: Web.ATND.Util.Person,+ accepted :: Integer,+ waiting :: Integer,+ updatedAt :: ATNDTime + }+ deriving (Show, Eq)++-- | Get event data(JSON) +getEvents :: Maybe [EventId]+ -- ^ Event's id+ -> Maybe [Text]+ -- ^ List of keywords(and)+ -> Maybe [Text]+ -- ^ List of keywords(or)+ -> Maybe [Text]+ -- ^ hold on year-month(yyyymm)+ -> Maybe [Text]+ -- ^ hold on date(yyyymmdd)+ -> Maybe [Web.ATND.Util.Person]+ -- ^ User's id+ -> Maybe [Web.ATND.Util.Person]+ -- ^ User's nickname+ -> Maybe [Web.ATND.Util.Person]+ -- ^ User's twitter id+ -> Maybe [Web.ATND.Util.Person]+ -- ^ Owner's id+ -> Maybe [Web.ATND.Util.Person]+ -- ^ Owner's nickname+ -> Maybe [Web.ATND.Util.Person]+ -- ^ Owner's twitter id+ -> Maybe Integer+ -- ^ Start position of results(default: 1)+ -> Maybe Integer+ -- ^ Count of results(default: 10, min: 1, max: 10)+ -> ATNDT m Events+getEvents eventIds+ keywords+ keywordOrs+ yms+ ymds+ userIds+ userNicknames+ userTwitterIds+ ownerIds+ ownerNicknames+ ownerTwitterIds+ start+ count = do+ query EventApi queryList + where+ queryList = toQueryList [("events", fmap (map (pack . show . unEventId)) eventIds)+ , ("keyword", keywords)+ , ("keyword_or", keywordOrs)+ , ("ym", yms)+ , ("ymd", ymds)+ , ("user_id", fmap (map (pack . show . personId)) userIds)+ , ("nickname", fmap (map personNickname) userNicknames)+ , ("twitter_id", fmap (map (\user -> case personTwitterId user of+ Just uti -> uti + Nothing -> "")) userTwitterIds)+ , ("owner_id", fmap (map (pack . show. personId)) ownerIds)+ , ("owner_nickname", fmap (map personNickname) ownerNicknames)+ , ("owner_twitter_id", fmap (map (\o -> case personTwitterId o of+ Just oti -> oti + Nothing -> "")) ownerTwitterIds)+ , ("start", fmap (\x -> [pack $ show x]) start)+ , ("count", fmap (\x -> [pack $ show x]) count)+ , ("format", Just [pack $ "json"])+ ]++instance ToJSON EventId where+ toJSON (EventId t) = object ["event_id" .= t]++instance FromJSON Events where+ parseJSON (Object v) = Events <$> v .: "events"+ parseJSON _ = mzero++instance FromJSON Event where+ parseJSON (Object v) = Event <$>+ v .: "event" <*>+ (e >>= (.: "title")) <*>+ (e >>= (.:? "catch")) <*>+ (e >>= (.: "description")) <*>+ (e >>= (.: "event_url")) <*>+ (e >>= (.: "started_at")) <*>+ (e >>= (.: "ended_at")) <*>+ (e >>= (.:? "url")) <*>+ (e >>= (.: "limit")) <*>+ (e >>= (.: "address")) <*>+ (e >>= (.: "place")) <*>+ (e >>= (.: "lat")) <*>+ (e >>= (.: "lon")) <*>+ (Web.ATND.Util.Person <$>+ (e >>= (.: "owner_id")) <*>+ (e >>= (.: "owner_nickname")) <*>+ (e >>= (.:? "owner_twitter_id"))) <*>+ (e >>= (.: "accepted")) <*>+ (e >>= (.: "waiting")) <*>+ (e >>= (.: "updated_at"))+ where e = (v .: "event")+ parseJSON _ = mzero++instance FromJSON EventId where+ parseJSON (Object v) = EventId <$> v .: "event_id"+ parseJSON _ = mzero
+ src/Web/ATND/Util.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Utility of ATND API method +--+module Web.ATND.Util+ (+ -- * data + Section(..),+ ATNDTime(..),+ Person(..),+ -- * method+ fromSection,+ toQueryList,+ filterQuery + ) where++import Data.Aeson (Value(..), FromJSON(..))++import Data.Text (Text, unpack)+import qualified Data.ByteString.Char8 as B8+import Data.Text.Encoding (encodeUtf8)+import Data.Time++import Control.Monad (mzero)+++-- | ATND api type+data Section = UserApi | EventApi deriving(Show, Eq)++-- | convert ATND api type to path +fromSection :: Section -> Text+fromSection UserApi = "events/users"+fromSection EventApi = "events"++-- | Respresents ATND time format+newtype ATNDTime = ATNDTime { unATNDTime :: UTCTime }++instance Eq ATNDTime where+ x == y = unATNDTime x == unATNDTime y++instance Show ATNDTime where+ show x = show $ unATNDTime x++atndTimeFormat :: String+atndTimeFormat = "%FT%T%Q%z"+ +instance FromJSON ATNDTime where+ parseJSON (String s) = maybe mzero (return . ATNDTime) $ + parseTimeM True defaultTimeLocale atndTimeFormat (unpack s) + parseJSON _ = mzero++-- | Represent an person(user or owner)+data Person = Person { personId :: Integer,+ personNickname :: Text,+ personTwitterId :: Maybe Text+ } deriving (Show, Eq)++-- | Remove Nothing from query list.+filterQuery :: [(a, Maybe a)] -> [(a, Maybe a)]+filterQuery = filter isNothing+ where+ isNothing (_, Nothing) = False+ isNothing _ = True++-- | Make query list +toQueryList :: [(B8.ByteString, Maybe [Text])] -> [(B8.ByteString, Maybe B8.ByteString)]+toQueryList xs = concat $ map (\(k, ys) -> case ys of+ Just zs -> map (\x -> (k, Just $ encodeUtf8 x)) zs+ Nothing -> []) xs+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}