diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. 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/atndapi.cabal b/atndapi.cabal new file mode 100644 --- /dev/null +++ b/atndapi.cabal @@ -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 diff --git a/src/Web/ATND.hs b/src/Web/ATND.hs new file mode 100644 --- /dev/null +++ b/src/Web/ATND.hs @@ -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 diff --git a/src/Web/ATND/Event.hs b/src/Web/ATND/Event.hs new file mode 100644 --- /dev/null +++ b/src/Web/ATND/Event.hs @@ -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 diff --git a/src/Web/ATND/Util.hs b/src/Web/ATND/Util.hs new file mode 100644 --- /dev/null +++ b/src/Web/ATND/Util.hs @@ -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 + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}