diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2011, Michael Xavier. 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,5 @@ +Web.Campfire +------------ + +Haskell implementation of the Campfire api. For more info, see +http://www.campfirenow.com diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain + diff --git a/Web/Campfire.hs b/Web/Campfire.hs new file mode 100644 --- /dev/null +++ b/Web/Campfire.hs @@ -0,0 +1,339 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Campfire +-- Description : Toplevel module for the Campfire API +-- Copyright : (c) Michael Xavier 2011 +-- License : MIT +-- +-- Maintainer: Michael Xavier +-- Stability : provisional +-- Portability: portable +-- +-- Toplevel module for the Campfire API operating in the CamfireM monad. +-- Covers the entire campfire API excluding the streaming and file upload APIs. +-- Might include support for these features in the future. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Web.Campfire +-- > import Web.Campfire.Monad +-- > import Web.Campfire.Types +-- > import Control.Monad.Reader +-- > import Data.Text (unpack) +-- > +-- > doStuff :: CampfireM () +-- > doStuff = do +-- > (room:_) <- getRooms +-- > let rid = roomId room +-- > joinRoom rid +-- > speak rid stmt +-- > leaveRoom rid +-- > return () +-- > where stmt = TextStatement { statementBody = "ATTENTION: I have nothing important to say" } +-- > +-- > main :: IO () +-- > main = do +-- > runReaderT (unCampfireM doStuff) env +-- > me <- runReaderT (unCampfireM getMe) env +-- > putStrLn "Hello, my name is:" +-- > putStrLn . unpack $ userName me +-- > where env = CampfireEnv { cfKey = "MYKEY", cfSubDomain = "mysubdomain"} +-- +-------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings #-} +module Web.Campfire ( getRooms, + getRoom, + getPresence, + setRoomTopic, + setRoomName, + joinRoom, + leaveRoom, + lockRoom, + unlockRoom, + getMe, + getUser, + speak, + highlightMessage, + unhighlightMessage, + getRecentMessages, + getUploads, + getUpload, + search, + getTodayTranscript, + getTranscript + ) where + +import Web.Campfire.Types +import Web.Campfire.Monad + +import qualified Data.Text as T +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Text.Encoding (encodeUtf8) +import Data.Aeson +import Data.Attoparsec (parse, eitherResult) +import Data.Time.Calendar (Day(..), toGregorian) + +--import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader + +import Network.URL (encString, ok_path) +import Network.HTTP.Enumerator +import Network.HTTP.Types (methodGet, + methodPut, + methodPost, + methodDelete, + headerContentType, + Method, + Query) + +--------- Room Operations +-- |Get a list of rooms visible to the authenticated user. +getRooms :: CampfireM [Room] +getRooms = withEnv $ \key sub -> do + resp <- doGet key sub "rooms.json" [] + let result = handleResponse resp + return $ (unRooms . unWrap . readResult) result + +-- |Get a specific room by Room ID. +getRoom :: Id -- ^ Room ID + -> CampfireM Room +getRoom rid = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + let room = unRootRoom $ (unWrap . readResult) result + return $ room { roomId = rid } + where pth = T.concat ["room/", i2t rid, ".json"] + +-- |Get a list of rooms in which the authenticated user is present. +getPresence :: CampfireM [Room] +getPresence = withEnv $ \key sub -> do + resp <- doGet key sub "presence.json" [] + let result = handleResponse resp + return $ (unRooms . unWrap . readResult) result + +-- |Change the topic of a particular room. +setRoomTopic :: Id -- ^ Room ID + -> T.Text -- ^ New topic + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +setRoomTopic rid topic = updateRoom rid RoomUpdate { updateRoomName = Nothing, + updateRoomTopic = Just topic } + +-- |Change the name of a particular room. +setRoomName :: Id -- ^ Room ID + -> T.Text -- ^ New room name + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +setRoomName rid name = updateRoom rid RoomUpdate { updateRoomName = Just name, + updateRoomTopic = Nothing } + +updateRoom :: Id -> RoomUpdate -> CampfireM (Int, LBS.ByteString) +updateRoom rid update = withEnv $ \key sub -> + doPut key sub pth $ encode update + where pth = T.concat ["room/", i2t rid, ".json"] + +-- |Causes the authenticated user to join a particular room. +joinRoom :: Id -- ^ Room ID + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +joinRoom rid = withEnv $ \key sub -> + doPost key sub pth LBS.empty + where pth = T.concat ["room/", i2t rid, "/join.json"] + +-- |Causes the authenticated user to leave a particular room. +leaveRoom :: Id -- ^ Room ID + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +leaveRoom rid = withEnv $ \key sub -> + doPost key sub pth LBS.empty + where pth = T.concat ["room/", i2t rid, "/leave.json"] + +-- |Locks a particular room. +lockRoom :: Id -- ^ Roomd ID + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +lockRoom rid = withEnv $ \key sub -> + doPost key sub pth LBS.empty + where pth = T.concat ["room/", i2t rid, "/lock.json"] + +-- |Unlocks a particular room. +unlockRoom :: Id -- ^ Room ID + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +unlockRoom rid = withEnv $ \key sub -> + doPost key sub pth LBS.empty + where pth = T.concat ["room/", i2t rid, "/unlock.json"] + +--------- User Operations + +-- |Get information about the currently authenticated user. +getMe :: CampfireM User +getMe = withEnv $ \key sub -> do + resp <- doGet key sub "users/me.json" [] + let result = handleResponse resp + return $ (unRootUser . unWrap . readResult) result + +-- |Get information about the requested user. +getUser :: Id -- ^ User ID + -> CampfireM User +getUser rid = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + return $ (unRootUser . unWrap . readResult) result + where pth = T.concat ["users/", i2t rid, ".json"] + +--------- Message Operations + +-- |Say something in a room as the currently authenticated user. +speak :: Id -- ^ The room ID in which to speak + -> Statement -- ^ The statement to send to the room + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +speak rid stmt = withEnv $ \key sub -> + doPost key sub pth $ encode stmt + where pth = T.concat ["room/", i2t rid, "/speak.json"] + +-- |Put a star next to a message. That message will then show up in that day's highlights. +highlightMessage :: Id -- ^ Message ID + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +highlightMessage mid = withEnv $ \key sub -> + doPost key sub pth LBS.empty + where pth = T.concat ["messages/", i2t mid, "/star.json"] + +-- |Remove the star next to a message. +unhighlightMessage :: Id -- ^ Message ID + -> CampfireM (Int, LBS.ByteString) -- ^ Status code and body (may change) +unhighlightMessage mid = withEnv $ \key sub -> + doDelete key sub pth LBS.empty + where pth = T.concat ["messages/", i2t mid, "/star.json"] + +-- |Receive a list of recent messages in a particular room. +getRecentMessages :: Id -- ^ Room ID + -> Maybe Integer -- ^ Optional limit. Default is 100 + -> Maybe Integer -- ^ Optional message ID. Setting this will retreive messages since that message was received. + -> CampfireM [Message] +getRecentMessages rid limit since_id = withEnv $ \key sub -> do + resp <- doGet key sub pth params + let result = handleResponse resp + return $ (unMessages . unWrap . readResult) result + where params = limitP limit ++ limitS since_id + pth = T.concat ["room/", i2t rid, "/recent.json"] + limitP (Nothing) = [] + limitP (Just l) = [("limit", Just $ BS.pack $ show l)] + limitS (Nothing) = [] + limitS (Just i) = [("since_message_id", Just $ BS.pack $ show i)] + +-- |Get a transcript of all messages in a room for the day. +getTodayTranscript :: Id -- ^ Room ID + -> CampfireM [Message] +getTodayTranscript rid = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + return $ (unMessages . unWrap . readResult) result + where pth = T.concat ["room/", i2t rid, "/transcript.json"] + +-- |Get a transcript of all messages in a room for a particular day +getTranscript :: Id -- ^ Room ID + -> Day -- ^ Day from which to retrieve the transcript + -> CampfireM [Message] +getTranscript rid day = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + return $ (unMessages . unWrap . readResult) result + where pth = T.concat ["room/", i2t rid, "/transcript/", i2t y, + "/", i2t m, "/", i2t d, ".json"] + (y, m, d) = toGregorian day + +--------- Upload Operations + +-- |Get a list of up to 5 recent uploads to a given room +getUploads :: Id -- ^ Room ID + -> CampfireM [Upload] +getUploads rid = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + return $ (unUploads . unWrap . readResult) result + where pth = T.concat ["room/", i2t rid, "/uploads.json"] + +--FIXME: this may not work, getting 404s + +-- |Retrieve a particular upload from a room. +getUpload :: Id -- ^ Room ID + -> Id -- ^ Upload ID + -> CampfireM Upload +getUpload rid uid = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + let upload = unRootUpload $ (unWrap . readResult) result + return upload + where pth = T.concat ["room/", i2t rid, "/messages/", + i2t uid, "/upload.json"] + +--------- Search Operations + +-- |Search for messages matching a given term. +search :: T.Text -- ^ Search string + -> CampfireM [Message] +search term = withEnv $ \key sub -> do + resp <- doGet key sub pth [] + let result = handleResponse resp + return $ (unMessages . unWrap . readResult) result + where pth = T.concat ["search/", encTerm, ".json"] + encTerm = T.pack $ encString True ok_path $ T.unpack term + +--------- Helpers +withEnv :: (T.Text -> T.Text -> CampfireM a) -> CampfireM a +withEnv fn = do + key <- asks cfKey + sub <- asks cfSubDomain + fn key sub + +i2t :: (Integral a) => a -> T.Text +i2t = T.pack . show + +unWrap :: (FromJSON a) => Result a -> a +unWrap (Success a) = a +unWrap (Error err) = error $ "parse error: " ++ err + +doGet :: T.Text -> T.Text -> T.Text -> Query -> CampfireM (Int, LBS.ByteString) +doGet key sub pth params = liftIO $ withManager $ \manager -> do + Response { statusCode = c, responseBody = b} <- httpLbsRedirect req manager + return (c, b) + where req = genRequest key sub pth params methodGet LBS.empty + +doPost :: T.Text -> T.Text -> T.Text -> LBS.ByteString -> CampfireM (Int, LBS.ByteString) +doPost = postWithPayload methodPost + +doPut :: T.Text -> T.Text -> T.Text -> LBS.ByteString -> CampfireM (Int, LBS.ByteString) +doPut = postWithPayload methodPut + +doDelete :: T.Text -> T.Text -> T.Text -> LBS.ByteString -> CampfireM (Int, LBS.ByteString) +doDelete = postWithPayload methodDelete + +postWithPayload :: Method -> T.Text -> T.Text -> T.Text -> LBS.ByteString -> CampfireM (Int, LBS.ByteString) +postWithPayload meth key sub pth pay = liftIO $ withManager $ \manager -> do + Response { statusCode = c, responseBody = b} <- httpLbsRedirect req manager + return (c, b) + where req = genRequest key sub pth [] meth pay + +genRequest :: T.Text -> T.Text -> T.Text -> Query -> Method -> LBS.ByteString -> Request IO +genRequest key sub pth params meth pay = applyBasicAuth bkey "X" Request { + method = meth, + secure = True, + checkCerts = \_ -> return True, -- uhhh + host = h, + port = 443, + path = encodeUtf8 pth, + queryString = params, + requestHeaders = headers, + requestBody = RequestBodyLBS pay } + where h = encodeUtf8 $ T.concat [sub, ".campfirenow.com"] + headers = [headerContentType "application/json"] + bkey = encodeUtf8 key + +handleResponse :: (Int, LBS.ByteString) -> Either Int T.Text +handleResponse (200, str) = Right $ T.pack $ LBS.unpack str +handleResponse (code, _) = Left code + +--TODO proper error handling +readResult :: (FromJSON r) => Either Int T.Text -> Result r +readResult (Right txt) = handleParse $ eitherResult $ parse json bs + where handleParse (Right obj) = fromJSON obj + handleParse (Left err) = error $ "Failed to parse: " ++ show err + bs = encodeUtf8 txt +readResult (Left code) = error $ "Unexpected Code: " ++ show code diff --git a/Web/Campfire/Monad.hs b/Web/Campfire/Monad.hs new file mode 100644 --- /dev/null +++ b/Web/Campfire/Monad.hs @@ -0,0 +1,27 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Campfire.Monad +-- Description : Monadic interface for communcating with the Campfire API +-- Copyright : (c) Michael Xavier 2011 +-- License : MIT +-- +-- Maintainer: Michael Xavier +-- Stability : provisional +-- Portability: portable +-- +-------------------------------------------------------------------- + +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Web.Campfire.Monad where + +import qualified Data.Text as T +import Control.Monad.Reader + +-- |Authentication environment used in Campfire API calls +data CampfireEnv = CampfireEnv { cfKey :: T.Text, -- ^ Authentication token. Obtained from the user info page in Campfire + cfSubDomain :: T.Text -- ^ The subdomain on the Campfire website to authenticate against + } + +-- |IO wrapper used to chain and compose Campfire API actions +newtype CampfireM a = CampfireM {unCampfireM :: ReaderT CampfireEnv IO a} + deriving (Monad, MonadIO, MonadReader CampfireEnv) diff --git a/Web/Campfire/Types.hs b/Web/Campfire/Types.hs new file mode 100644 --- /dev/null +++ b/Web/Campfire/Types.hs @@ -0,0 +1,300 @@ +-------------------------------------------------------------------- +-- | +-- Module : Web.Campfire.Types +-- Description : Types returned by the Campfire API +-- Copyright : (c) Michael Xavier 2011 +-- License : MIT +-- +-- Maintainer: Michael Xavier +-- Stability : provisional +-- Portability: portable +-- +-------------------------------------------------------------------- + +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, OverloadedStrings #-} +module Web.Campfire.Types ( Room(..), + RoomWithRoot(..), + Rooms(..), + RoomUpdate(..), + Message(..), + Messages(..), + MessageType(..), + Statement(..), + Sound(..), + User(..), + UserWithRoot(..), + UserType(..), + Upload(..), + Uploads(..), + UploadWithRoot(..), + Id, + CampfireTime(..) ) where + +import Control.Applicative ((<$>), (<*>), pure) +import Control.Monad (mzero) +import Data.Aeson +import qualified Data.Aeson.Types as AT (typeMismatch, Parser) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Time.Format +import qualified Data.Map as M +import Data.Text +import Data.Typeable +import Locale (defaultTimeLocale) + +---------- Rooms +-- |A chat room on a Campfire site +data Room + = Room { roomId :: Id, + roomName :: T.Text, + roomTopic :: Maybe T.Text, -- ^ Room topic if available + roomMembershipLimit :: Integer, -- ^ Maximum number of users that may be in this room + roomFull :: Maybe Bool, -- ^ May not be present depending on the API call used + roomOpenToGuests :: Maybe Bool, -- ^ May not be present depending on the API call used + roomActiveTokenValue :: Maybe T.Text, -- ^ Campfire API doesn't really specify what this means + roomUpdatedAt :: CampfireTime, + roomCreatedAt :: CampfireTime, + roomUsers :: Maybe [User] } deriving (Eq, Ord, Read, Show, Typeable) + + -- There is probably a better way to do this +instance FromJSON Room where + parseJSON (Object v) = Room <$> v .:| ("id", 0) + <*> v .: "name" + <*> v .: "topic" + <*> v .: "membership_limit" + <*> v .:? "full" + <*> v .:? "open_to_guests" + <*> v .:? "active_token_value" + <*> v .: "updated_at" + <*> v .: "created_at" + <*> v .:? "users" + parseJSON _ = mzero + +-- |Utility type used for extracting a Room from the root JSON object the Campfire API returns +newtype RoomWithRoot = RoomWithRoot { unRootRoom :: Room } deriving (Eq, Ord, Read, Show, Typeable) + + +instance FromJSON RoomWithRoot where + parseJSON (Object v) = RoomWithRoot <$> v .: "room" + parseJSON _ = mzero + + +-- |Utility type used for extracting a Room from the list returned by the Campfire API +newtype Rooms = Rooms { unRooms :: [Room] } deriving (Eq, Ord, Read, Show, Typeable) + + +instance FromJSON Rooms where + parseJSON (Object v) = Rooms <$> v .: "rooms" + parseJSON _ = mzero + + +-- |Modification to be made to a room. +data RoomUpdate = RoomUpdate { updateRoomName :: Maybe T.Text, + updateRoomTopic :: Maybe T.Text } deriving (Eq, Ord, Read, Show, Typeable) + +--TODO: maybe omit missing fields +instance ToJSON RoomUpdate where + toJSON RoomUpdate {updateRoomName = n, updateRoomTopic = t} = + "room" |- object ["name" .= n, "topic" .= t] + + +---------- Messages + +-- |A single line of dialog in a particular chat +data Message = Message { messageId :: Id, + messageBody :: Maybe T.Text, + messageRoomId :: Id, + messageUserId :: Maybe Id, + messageCreatedAt :: CampfireTime, + messageType :: MessageType } deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON Message where + -- consider using an ADT for type + parseJSON (Object v) = Message <$> v .: "id" + <*> v .: "body" + <*> v .: "room_id" + <*> v .: "user_id" + <*> v .: "created_at" + <*> v .: "type" + parseJSON _ = mzero + +-- |Utility type used for extracting a Message from the list returned by the Campfire API +newtype Messages = Messages { unMessages :: [Message] } deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON Messages where + parseJSON (Object v) = Messages <$> v .: "messages" + parseJSON _ = mzero + + +-- |Distinct types of messages which can be found in Campfire +data MessageType = TextMessage | + PasteMessage | -- ^ Monospaced text displayed in block form + SoundMessage | -- ^ Audio sound effect message + AdvertisementMessage | + AllowGuestsMessage | + DisallowGuestsMessage | + IdleMessage | + KickMessage | -- ^ Message indicating that a user was kicked out + LeaveMessage | + SystemMessage | + TimestampMessage | + TopicChangeMessage | + UnidleMessage | + UnlockMessage | + UploadMessage | + EnterMessage + deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON MessageType where + parseJSON (String v) = case unpack v of + "TextMessage" -> pure TextMessage + "PasteMessage" -> pure PasteMessage + "SoundMessage" -> pure SoundMessage + "AdvertisementMessage" -> pure AdvertisementMessage + "AllowGuestsMessage" -> pure AllowGuestsMessage + "DisallowGuestsMessage" -> pure DisallowGuestsMessage + "IdleMessage" -> pure IdleMessage + "KickMessage" -> pure KickMessage + "LeaveMessage" -> pure LeaveMessage + "SystemMessage" -> pure SystemMessage + "TimestampMessage" -> pure TimestampMessage + "TopicChangeMessage" -> pure TopicChangeMessage + "UnidleMessage" -> pure UnidleMessage + "UnlockMessage" -> pure UnlockMessage + "UploadMessage" -> pure UploadMessage + "EnterMessage" -> pure EnterMessage + _ -> mzero + parseJSON _ = mzero + +---------- Statements +-- |Statements are messages that you can send to CampFire. +data Statement = TextStatement { statementBody :: T.Text } | + PasteStatement { statementBody :: T.Text} | + SoundStatement { soundType :: Sound } | -- ^ Play an audio message in the room + TweetStatement { statementUrl :: T.Text} -- ^ Display a tweet from a url on Twitter + deriving (Eq, Ord, Read, Show, Typeable) + +instance ToJSON Statement where + toJSON TextStatement { statementBody = b} = + "message" |- object ["type" .= ("TextMessage" :: T.Text), "body" .= b] + toJSON PasteStatement { statementBody = b} = + "message" |- object ["type" .= ("PasteMessage" :: T.Text), "body" .= b] + toJSON SoundStatement { soundType = t } = + "message" |- object ["type" .= ("SoundMessage" :: T.Text), "body" .= t] + toJSON TweetStatement { statementUrl = u } = + "message" |- object ["type" .= ("TweetStatemetn" :: T.Text), "body" .= u] + +(|-) :: T.Text -> Value -> Value +(|-) label obj = object [label .= obj] + + +-- |Different pre-set sounds that can be played in a room. +data Sound = Rimshot | + Crickets | + Trombone + deriving (Eq, Ord, Read, Show, Typeable) + +instance ToJSON Sound where + toJSON Rimshot = String "rimshot" + toJSON Crickets = String "crickets" + toJSON Trombone = String "trombone" + + +---------- Users + +-- |User which can be found in any number of rooms. +data User = User { userId :: Id, + userName :: T.Text, + userEmailAddress :: T.Text, + userAdmin :: Bool, -- ^ User has administrative privileges + userCreatedAt :: CampfireTime, + userType :: UserType } + deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON User where + -- consider using an ADT for type + parseJSON (Object v) = User <$> v .: "id" + <*> v .: "name" + <*> v .: "email_address" + <*> v .: "admin" + <*> v .: "created_at" + <*> v .: "type" + parseJSON _ = mzero + +-- |Utility type used for extracting a User from the root JSON object the Campfire API returns +newtype UserWithRoot = UserWithRoot { unRootUser :: User } deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON UserWithRoot where + parseJSON (Object v) = UserWithRoot <$> v .: "user" + parseJSON _ = mzero + +-- |Different classes of users that can be found in chat. +data UserType = Member | + Guest + deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON UserType where + parseJSON (String v) = case unpack v of + "Member" -> pure Member + "Guest" -> pure Guest + _ -> mzero + parseJSON _ = mzero + +---------- Uploads + +-- |File upload in a room. +data Upload = Upload { uploadId :: Id, + uploadName :: T.Text, + uploadRoomId :: Id, + uploadUserId :: Id, + uploadByteSize :: Integer, + uploadContentType :: T.Text, + uploadFullUrl :: T.Text, + uploadCreatedAt :: CampfireTime } + deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON Upload where + -- consider using an ADT for type + parseJSON (Object v) = Upload <$> v .: "id" + <*> v .: "name" + <*> v .: "room_id" + <*> v .: "user_id" + <*> v .: "byte_size" + <*> v .: "content_type" + <*> v .: "full_url" + <*> v .: "created_at" + parseJSON _ = mzero + +-- |Utility type used for extracting a Upload from the list returned by the Campfire API +newtype Uploads = Uploads { unUploads :: [Upload] } deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON Uploads where + parseJSON (Object v) = Uploads <$> v .: "uploads" + parseJSON _ = mzero + +-- |Utility type used for extracting an Upload from the root JSON object the Campfire API returns +newtype UploadWithRoot = UploadWithRoot { unRootUpload :: Upload } deriving (Eq, Ord, Read, Show, Typeable) + +instance FromJSON UploadWithRoot where + parseJSON (Object v) = UploadWithRoot <$> v .: "upload" + parseJSON _ = mzero + +---------- General Purpose Types +type Id = Integer + +-- |Utility type to normalize the non-standard date format that the Campfire API returns +newtype CampfireTime = CampfireTime { + fromCampfireTime :: UTCTime + } deriving (Eq, Ord, Read, Show, Typeable, FormatTime) + +instance FromJSON CampfireTime where + parseJSON (String t) = case parseTime defaultTimeLocale "%Y/%m/%d %T %z" (unpack t) of + Just d -> pure (CampfireTime d) + _ -> fail "Could not parse Campfire-formatted time" + parseJSON v = AT.typeMismatch "CampfireTime" v + +-- Helpers +(.:|) :: (FromJSON a) => Object -> (Text, a) -> AT.Parser a +obj .:| (key, d) = case M.lookup key obj of + Nothing -> pure d + Just v -> parseJSON v diff --git a/campfire.cabal b/campfire.cabal new file mode 100644 --- /dev/null +++ b/campfire.cabal @@ -0,0 +1,44 @@ +name: campfire +version: 0.0.1 +synopsis: Haskell implementation of the Campfire API +description: + Implements the Campfire REST API. Campfire is a business group chat system + tailored specifically for work groups. Find out more at + . + + Currently supports the entire API except for streaming and file uploads. + Stability is listed as provisional because there are currently no formal + tests in place. + +category: Web +license: BSD3 +license-file: LICENSE +author: Michael Xavier +maintainer: Michael Xavier +cabal-version: >= 1.6 +build-type: Simple +extra-source-files: README +homepage: http://github.com/michaelxavier/Campfire + +library + Exposed-modules: Web.Campfire, + Web.Campfire.Types, + Web.Campfire.Monad + Ghc-Options: -Wall + build-depends: base >= 4 && < 5, + aeson >= 0.3.1.1 && < 0.4, + bytestring >= 0.9.1.10 && < 0.10, + text >= 0.11.0.5 && < 0.12, + attoparsec >= 0.8.5.0 && < 0.9, + http-enumerator >= 0.6.5 && < 0.7, + mtl >= 2.0.1.0 && < 2.1, + time >= 1.2.0.3 && < 1.3, + transformers >= 0.2.2.0 && < 0.3, + http-types >= 0.6.0 && < 0.7, + url >= 2.1.2 && < 2.3, + haskell98 >= 1.1.0.1 && < 1.2, + containers >= 0.4.0.0 && < 0.5 + +source-repository head + type: git + location: git://github.com/michaelxavier/Campfire.git