campfire (empty) → 0.0.1
raw patch · 7 files changed
+748/−0 lines, 7 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, bytestring, containers, haskell98, http-enumerator, http-types, mtl, text, time, transformers, url
Files
- LICENSE +25/−0
- README +5/−0
- Setup.lhs +8/−0
- Web/Campfire.hs +339/−0
- Web/Campfire/Monad.hs +27/−0
- Web/Campfire/Types.hs +300/−0
- campfire.cabal +44/−0
+ LICENSE view
@@ -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.
+ README view
@@ -0,0 +1,5 @@+Web.Campfire+------------++Haskell implementation of the Campfire api. For more info, see+http://www.campfirenow.com
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain+
+ Web/Campfire.hs view
@@ -0,0 +1,339 @@+--------------------------------------------------------------------+-- |+-- Module : Web.Campfire+-- Description : Toplevel module for the Campfire API+-- Copyright : (c) Michael Xavier 2011+-- License : MIT+--+-- Maintainer: Michael Xavier <michael@michaelxavier.net>+-- 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
+ Web/Campfire/Monad.hs view
@@ -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 <michael@michaelxavier.net>+-- 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)
+ Web/Campfire/Types.hs view
@@ -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 <michael@michaelxavier.net>+-- 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
+ campfire.cabal view
@@ -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+ <http://www.campfirenow.com>.++ 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 <michael@michaelxavier.net>+maintainer: Michael Xavier <michael@michaelxavier.net>+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