beeminder-api (empty) → 1.0
raw patch · 6 files changed
+1017/−0 lines, 6 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, blaze-builder, bytestring, conduit, containers, data-default-class, data-default-instances-base, http-conduit, http-types, lens, monad-control, mtl, resourcet, scientific, text, time, transformers, transformers-base, universe, universe-base, unordered-containers, vector
Files
- Data/Aeson/Encode/Shim.hs +149/−0
- LICENSE +30/−0
- Network/Beeminder.hs +111/−0
- Network/Beeminder/Internal.hs +672/−0
- Setup.hs +2/−0
- beeminder-api.cabal +53/−0
+ Data/Aeson/Encode/Shim.hs view
@@ -0,0 +1,149 @@+{-++Copyright (c) 2012 Bryan O'Sullivan, (c) 2011 MailRank, Inc.++MODIFIED by Brent Yorgey, February 2014.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.++-}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Data.Aeson.Encode.Shim+-- Copyright : (c) 2012 Bryan O'Sullivan+-- (c) 2011 MailRank, Inc.+-- (c) 2014 Brent Yorgey+-- License : BSD3+-- Maintainer : Brent Yorgey <byorgey@gmail.com>+--+-- Beeminder's JSON parser does not accept floating-point values in+-- scientific format (even though that format is allowed by the JSON+-- standard). To work around this, we use a slightly modified variant+-- of aeson's encoding which never uses scientific notation for+-- encoded floating-point values (the modification is marked by !!!!).+--+-----------------------------------------------------------------------------++module Data.Aeson.Encode.Shim (encode) where++import Data.Aeson.Types (Value (..))+import qualified Data.HashMap.Strict as H+import Data.Monoid (mappend)+import Data.Scientific (FPFormat (Fixed),+ Scientific, base10Exponent,+ coefficient)+import qualified Data.Text as T+import Data.Text.Lazy.Builder+import Data.Text.Lazy.Builder.Int (decimal)+import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)+import qualified Data.Vector as V+import Numeric (showHex)++#if MIN_VERSION_bytestring(0,10,4)+import Data.Aeson (encode)+#else+import Data.Aeson.Types (ToJSON (toJSON))+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Lazy.Encoding as TLE++-- | Encode a JSON 'Value' as a UTF-8 encoded 'BL.ByteString'.+encode :: ToJSON a => a -> BL.ByteString+encode = TLE.encodeUtf8 . TLB.toLazyText . encodeToTextBuilder . toJSON+#endif++-- | Encode a JSON 'Value' to a 'Builder', which can be embedded efficiently+-- in a text-based protocol.+encodeToTextBuilder :: Value -> Builder+encodeToTextBuilder =+ go+ where+ go Null = {-# SCC "go/Null" #-} "null"+ go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false"+ go (Number s) = {-# SCC "go/Number" #-} fromScientific s+ go (String s) = {-# SCC "go/String" #-} string s+ go (Array v)+ | V.null v = {-# SCC "go/Array" #-} "[]"+ | otherwise = {-# SCC "go/Array" #-}+ singleton '[' <>+ go (V.unsafeHead v) <>+ V.foldr f (singleton ']') (V.unsafeTail v)+ where f a z = singleton ',' <> go a <> z+ go (Object m) = {-# SCC "go/Object" #-}+ case H.toList m of+ (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs+ _ -> "{}"+ where f a z = singleton ',' <> one a <> z+ one (k,v) = string k <> singleton ':' <> go v++string :: T.Text -> Builder+string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'+ where+ quote q = case T.uncons t of+ Nothing -> fromText h+ Just (!c,t') -> fromText h <> escape c <> quote t'+ where (h,t) = {-# SCC "break" #-} T.break isEscape q+ isEscape c = c == '\"' ||+ c == '\\' ||+ c == '<' ||+ c == '>' ||+ c < '\x20'+ escape '\"' = "\\\""+ escape '\\' = "\\\\"+ escape '\n' = "\\n"+ escape '\r' = "\\r"+ escape '\t' = "\\t"++ -- The following prevents untrusted JSON strings containing </script> or -->+ -- from causing an XSS vulnerability:+ escape '<' = "\\u003c"+ escape '>' = "\\u003e"++ escape c+ | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h+ | otherwise = singleton c+ where h = showHex (fromEnum c) ""++fromScientific :: Scientific -> Builder+fromScientific s+ | e < 0 = formatScientificBuilder Fixed Nothing s -- !!!!+ | otherwise = decimal (coefficient s * 10 ^ e)+ where+ e = base10Exponent s++(<>) :: Builder -> Builder -> Builder+(<>) = mappend+{-# INLINE (<>) #-}+infixr 6 <>
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Daniel Wagner++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 Daniel Wagner 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.
+ Network/Beeminder.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+module Network.Beeminder+ ( -- * API calls+ user+ , goal, allGoals+ , createGoal+ , points+ , createPoint , createPointNotify+ , createPoints, createPointsNotify+ , updatePoint , deletePoint++ -- * The Beeminder monad+ , Beeminder+ , Token+ , runBeeminder++ -- * Foo bar+ , UserGoals(..)+ , User(..)+ , Point(..)+ , Goal(..)+ -- UserGoals stuff+ , Burner(..), LevelOfGoalDetail(..)+ -- Goal stuff+ , TimeFrame(..), Aggregate(..), Direction(..), Behavior(..), Target(..), GoalType(..)++ -- * Lenses+ , HasID(..), HasUpdatedAt(..), HasName(..), HasTimezone(..), HasUsername(..), HasGoals(..), HasGoalsFilter(..), HasLevelOfDetail(..)+ , HasPointCount(..), HasTimestamp(..), HasValue(..), HasComment(..), HasRequestID(..), HasGoal(..), HasPointRequest(..), HasPointRequests(..)+ , HasGetPoints(..), HasTitle(..), HasType(..), HasTarget(..), HasBehavior(..), HasPanic(..)++ -- * Utilities+ , now+ , gType+ ) where++import Control.Applicative+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Resource+import Data.Aeson+import Data.Conduit+import Data.Default.Class+import Network.Beeminder.Internal hiding (allGoals, createGoal,+ createPoint, createPointNotify,+ createPoints, createPointsNotify,+ deletePoint, goal, points,+ updatePoint, user)+import qualified Network.Beeminder.Internal as Internal+import Network.HTTP.Conduit++data BeeminderEnvironment = BeeminderEnvironment+ { token :: Token+ , manager :: Manager+ }++type Beeminder_ = MaybeT (ReaderT BeeminderEnvironment (ResourceT IO))+newtype Beeminder a = Beeminder { unBeeminder :: Beeminder_ a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader BeeminderEnvironment, MonadThrow, MonadResource, MonadBase IO)++-- The following instance (and the "deriving" clause for MonadThrow,+-- MonadUnsafeIO, MonadResource, and MonadBase IO) were copied basically+-- verbatim from the "dgs" package, and even there they were written just "by+-- typechecking" rather than with some deep understanding of what's happening.+-- So it wouldn't surprise me if there's bugs here.+instance MonadBaseControl IO Beeminder where+ type StM Beeminder a = StM Beeminder_ a+ liftBaseWith f = Beeminder (liftBaseWith (\g -> f (\(Beeminder m) -> g m)))+ restoreM v = Beeminder (restoreM v)++-- | Run a beeminder computation with the given authentication token,+-- possibly returning a result.+runBeeminder :: Token -> Beeminder a -> IO (Maybe a)+runBeeminder t m = do+ man <- newManager tlsManagerSettings+ runResourceT (runReaderT (runMaybeT (unBeeminder m)) BeeminderEnvironment { token = t, manager = man })++-- | Turn a raw operation taking a token and returning a 'Request'+-- into a nicely encapsulated action in the 'Beeminder' monad.+externalize :: FromJSON a => (Token -> params -> Request) -> params -> Beeminder a+externalize f p = do+ BeeminderEnvironment { token = t, manager = m } <- ask+ r <- httpLbs (f t p) {responseTimeout = Nothing} m+ Beeminder . MaybeT . return . decode . responseBody $ r++user :: UserParameters -> Beeminder User+goal :: GoalParameters -> Beeminder Goal+allGoals :: AllGoalsParameters -> Beeminder [Goal]+createGoal :: CreateGoalParameters -> Beeminder Goal+points :: PointsParameters -> Beeminder [Point]+createPoint , createPointNotify :: CreatePointParameters -> Beeminder Point+createPoints, createPointsNotify :: CreatePointsParameters -> Beeminder [Point]+updatePoint :: UpdatePointParameters -> Beeminder Point+deletePoint :: DeletePointParameters -> Beeminder Point++user = externalize Internal.user+goal = externalize Internal.goal+allGoals = externalize Internal.allGoals+createGoal = externalize Internal.createGoal+points = externalize Internal.points+createPoint = externalize Internal.createPoint+createPointNotify = externalize Internal.createPointNotify+createPoints = externalize Internal.createPoints+createPointsNotify = externalize Internal.createPointsNotify+updatePoint = externalize Internal.updatePoint+deletePoint = externalize Internal.deletePoint
+ Network/Beeminder/Internal.hs view
@@ -0,0 +1,672 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+module Network.Beeminder.Internal where++import Blaze.ByteString.Builder+import Control.Applicative+import Control.Lens hiding ((&), (.=))+import Control.Monad+import Control.Monad.IO.Class+import Data.Aeson hiding (encode)+import Data.Aeson.Encode.Shim (encode)+import Data.Aeson.Types+import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.Char+import Data.Conduit+import Data.Default.Class+import Data.Default.Instances.Base+import Data.List+import Data.Maybe+import Data.Monoid hiding (All, Last)+import Data.Ratio+import Data.Scientific (Scientific)+import Data.Set (Set)+import Data.String+import Data.Text (Text)+import Data.Text.Encoding+import Data.Time.Clock.POSIX+import Data.Universe+import Data.Universe.Helpers+import Network.HTTP.Conduit+import Network.HTTP.Types++import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder+import qualified Data.ByteString as BS+import qualified Data.Set as Set+import qualified Data.Vector as Vector++-- things that ought to be in somebody else's module/package {{{+renderSimpleQueryText b xs = toByteString (renderQueryText b [(x, Just y) | (x, y) <- xs])+urlEncodedBodyText xs = urlEncodedBody [(encodeUtf8 x, encodeUtf8 y) | (x, y) <- xs]+instance Default Text where def = ""+-- }}}++type Token = ByteString++baseReq token segments = def+ { secure = True+ , host = "www.beeminder.com"+ , port = 443+ , path = toByteString (encodePathSegments ("api":"v1":segments) <> Builder.fromString ".json")+ , queryString = "?auth_token=" <> token+ }++infixl 4 &+req & q+ | BS.null (queryString req) = req { queryString = renderSimpleQueryText True q }+ | otherwise = req { queryString = queryString req <> "&" <> renderSimpleQueryText False q }++-- TODO: make some top-level documentation with these details:+-- * all times are an Integer representing a Unix timestamp+-- * something about requested IDs, like how to request them and how to use them -- can they be used anywhere a normal ID can? (answer: no, they cannot)++class HasID a where _ID :: Simple Lens a Text+class HasUpdatedAt a where _UpdatedAt :: Simple Lens a Integer -- ^ you can use this to decide whether or not to use cached information+class HasName a where _Name :: Simple Lens a Text+class HasTimezone a where _Timezone :: Simple Lens a Text+class HasUsername a where _Username :: Simple Lens a (Maybe Text)+class HasGoals a where _Goals :: Simple Lens a UserGoals+class HasGoalsFilter a where _GoalsFilter :: Simple Lens a (Maybe Burner)+class HasLevelOfDetail a where _LevelOfDetail :: Simple Lens a LevelOfGoalDetail+class HasPointCount a where _PointCount :: Simple Lens a (Maybe Integer)+class HasTimestamp a where _Timestamp :: Simple Lens a Integer+class HasValue a where _Value :: Simple Lens a Double+class HasComment a where _Comment :: Simple Lens a Text+class HasRequestID a where _RequestID :: Simple Lens a (Maybe Text)+class HasGoal a where _Goal :: Simple Lens a Text+class HasPointRequest a where _PointRequest :: Simple Lens a PointRequest+class HasPointRequests a where _PointRequests :: Simple Lens a [PointRequest]+class HasGetPoints a where _GetPoints :: Simple Lens a Bool+class HasTitle a where _Title :: Simple Lens a Text+class HasType a where _Type :: Simple Lens a GoalType+class HasTarget a where _Target :: Simple Lens a Target+class HasBehavior a where _Behavior :: Simple Lens a (Set Behavior)+class HasPanic a where _Panic :: Simple Lens a Double++data UserGoals+ = Slugs [Text] -- ^ just the short names (use 'JustTheSlugs')+ | Hashes [Goal] -- ^ information about all currently existing goals (use 'EverythingCurrent')+ | Diff [Goal] [Text] -- ^ created or updated goals first, then IDs of deleted goals (use 'Diff')+ deriving (Eq, Ord, Show, Read)++-- | the '_UpdatedAt' value is the upper bound of all updates -- even nested+-- ones to goals, points, etc.+data User = User+ { uName :: Text+ , uTimezone :: Text+ , uGoals :: UserGoals+ , uID :: Text+ , uUpdatedAt :: Integer+ } deriving (Eq, Ord, Show, Read)++instance HasName User where _Name = lens uName (\s b -> s { uName = b })+instance HasTimezone User where _Timezone = lens uTimezone (\s b -> s { uTimezone = b })+instance HasGoals User where _Goals = lens uGoals (\s b -> s { uGoals = b })+instance HasID User where _ID = lens uID (\s b -> s { uID = b })+instance HasUpdatedAt User where _UpdatedAt = lens uUpdatedAt (\s b -> s { uUpdatedAt = b })++-- internal type used to get a free list instance when parsing the Diff part of UserGoals+data ID = ID { idID :: Text } deriving (Eq, Ord, Show, Read)+instance HasID ID where _ID = lens idID (\s b -> s { idID = b })+instance FromJSON ID where+ parseJSON (Object v) = ID <$> v .: "id"+ parseJSON o = typeMismatch "ID" o++instance FromJSON UserGoals where+ -- diff comes before hashes so that it is preferred when deleted_goals exists+ -- TODO: this isn't quite right... Diff is clearly differentiable from+ -- Slugs and Hashes, but those two (Slugs and Hashes) aren't differentiable+ -- when the goals list is empty -- need something better than a heuristic here!+ -- possible resolution: have separate User types for each?+ parseJSON (Object v) = slugs <|> diff <|> hashes where+ slugs = Slugs <$> v .: "goals"+ hashes = Hashes <$> v .: "goals"+ diff = Diff <$> v .: "goals" <*> (map idID <$> v .: "deleted_goals")+ parseJSON o = typeMismatch "hash with goals (either a list of slugs or a list of goal objects)" o++-- TODO: the implementation doesn't match the spec: it has "id" and+-- "has_authorized_fitbit" fields. I wonder what they're for!+instance FromJSON User where+ parseJSON o@(Object v) = User+ <$> v .: "username"+ <*> v .: "timezone"+ <*> parseJSON o+ <*> v .: "id"+ <*> v .: "updated_at"+ parseJSON o = typeMismatch "user object" o++data Burner = Front | Back deriving (Eq, Ord, Show, Read, Bounded, Enum)+instance FromJSON Burner where parseJSON = showStringChoices "burner" (++"burner")++-- TODO: list the attributes that you still get with 'skinny' (and test a call with skinny=True)+data LevelOfGoalDetail+ = JustTheSlugs -- ^ minimal detail: just the "slug" (the part that goes in a URL)+ | EverythingCurrent -- ^ details about all the currently existing goals++ -- the above blank line and the below breech of style are intentional haddock workarounds+ -- | maximal detail: report even about goals that have been deleted+ | DiffSince+ { since :: Integer -- ^ a Unix timestamp; show all the changes since that timestamp (new points, deleted goals, etc.)+ , skinny :: Bool -- ^ when 'True', return only each goal's latest data point and a subset of the attributes for each goal+ }+ deriving (Eq, Ord, Show, Read)++instance Default LevelOfGoalDetail where def = JustTheSlugs++data UserParameters = UserParameters+ { upUsername :: Maybe Text -- ^ 'Nothing' means \"whoever owns the API token\"+ , upGoalsFilter :: Maybe Burner -- ^ 'Nothing' means \"all goals\"; the 'Front' and 'Back' 'Burner's are the goals above and below the fold in the web interface+ , upLevelOfDetail :: LevelOfGoalDetail -- ^ how much information do you want about the user's goals?+ , upPointCount :: Maybe Integer -- ^ 'Nothing' means return all data points; 'Just' @n@ will return only the @n@ most recently added (not most recently timestamped!) data points+ } deriving (Eq, Ord, Show, Read)++instance Default UserParameters where def = UserParameters def def def def++-- TODO: look into using Control.Lens.TH.makeFields to reduce this boilerplate+instance HasUsername UserParameters where _Username = lens upUsername (\s b -> s { upUsername = b })+instance HasGoalsFilter UserParameters where _GoalsFilter = lens upGoalsFilter (\s b -> s { upGoalsFilter = b })+instance HasLevelOfDetail UserParameters where _LevelOfDetail = lens upLevelOfDetail (\s b -> s { upLevelOfDetail = b })+instance HasPointCount UserParameters where _PointCount = lens upPointCount (\s b -> s { upPointCount = b })++maybeMe :: HasUsername a => a -> Text+maybeMe v = fromMaybe "me" (view _Username v)++textShow, lowerShow :: Show a => a -> Text+textShow = fromString . show+lowerShow = fromString . map toLower . show++user :: Token -> UserParameters -> Request+user t p+ = baseReq t ["users", maybeMe p]+ & case view _LevelOfDetail p of+ JustTheSlugs -> []+ EverythingCurrent -> [("associations", "true")]+ DiffSince t d -> [("diff_since", lowerShow t), ("skinny", lowerShow d)]+ ++ [("goals_filter", lowerShow b) | Just b <- [view _GoalsFilter p]]+ ++ [("datapoints_count", lowerShow n) | Just n <- [view _PointCount p]]++data TimeFrame = Year | Month | Week | Day | Hour deriving (Eq, Ord, Show, Read, Bounded, Enum)+data Direction = Up | Down deriving (Eq, Ord, Show, Read, Bounded, Enum)+data Aggregate = Last | First | All | Min | Max | Mean | Sum+ deriving (Eq, Ord, Show, Read, Bounded, Enum)++instance FromJSON TimeFrame where parseJSON = showStringChoices "timeframe" (take 1)+instance FromJSON Aggregate where parseJSON = showStringChoices "aggregate" id+instance FromJSON Direction where+ parseJSON (Number (toRational -> 1)) = return Up+ parseJSON (Number (toRational -> -1)) = return Down+ parseJSON v = typeMismatch "direction (either 1 or -1)" v++showStringChoices s f = stringChoices s [(f . map toLower . show $ a, a) | a <- universeF]+stringChoices s cs_ v =+ case v of+ String t -> case lookup t cs of+ Just r -> return r+ Nothing -> wrong+ _ -> wrong+ where+ cs = [(fromString n, r) | (n, r) <- cs_]+ ns = map fst cs+ ns' = init ns+ n = last ns+ wrong = typeMismatch errorMessage v+ errorMessage = s <> " (" <> errorInternal <> ")"+ errorInternal = case ns of+ [] -> "there are no values of this type!"+ [n] -> "must be " <> show n+ [n, n'] -> "either " <> show n <> " or " <> show n'+ _ -> "one of " <> intercalate "," (map show ns') <> ", or " <> show n++data Behavior+ = Exponential -- ^ interpret rate as multiplicative rather than additive+ | Cumulative -- ^ plot values as the sum of the points+ | Odometer -- ^ treat zero as an odomoter reset rather than a literal 0+ | Edgy -- ^ initial data point goes at the road edge (not center)+ | Noisy -- ^ use points (not just rate) when computing road width+ | StepLine -- ^ use steppy-like line when rendering the graph+ | Rosy -- ^ show the optimistic rosy dots when rendering the graph+ | MovingAverage -- ^ graph the moving average+ | Aura -- ^ render the turquoise confidence area+ | Ephemeral -- ^ garbage collect this goal after a bit+ | Secret -- ^ only the owner can see the goal+ | SecretPoints -- ^ only the owner can see the points+ deriving (Eq, Ord, Show, Read, Bounded, Enum)++parseBehaviorSet v = do+ behaviors <- mapM (parseBehavior v) universeF+ return (Set.fromList [b | (b, h) <- behaviors, polarity b h])+ where+ parseBehavior v b = (,) b <$> (v .: fieldName b)+ fieldName Exponential = "exprd"+ fieldName Cumulative = "kyoom"+ fieldName Odometer = "odom"+ fieldName Edgy = "edgy"+ fieldName Noisy = "noisy"+ fieldName StepLine = "steppy"+ fieldName Rosy = "rosy"+ fieldName MovingAverage = "movingav"+ fieldName Aura = "aura"+ fieldName Ephemeral = "ephem"+ fieldName Secret = "secret"+ fieldName SecretPoints = "datapublic"+ polarity SecretPoints = not+ polarity _ = id++data Target+ = MissingDate { tValue :: Double, tRate :: Double }+ | MissingValue { tDate :: Integer, tRate :: Double }+ | MissingRate { tDate :: Integer, tValue :: Double }+ deriving (Eq, Ord, Show, Read)++toDouble :: Scientific -> Double+toDouble = fromRational . toRational++toIntegerMaybe :: Scientific -> Maybe Integer+toIntegerMaybe s+ | denominator r == 1 = Just $ numerator r+ | otherwise = Nothing+ where+ r = toRational s++toTarget o (Null ) (Number v) (Number r) = return $ MissingDate (toDouble v) (toDouble r)+toTarget o (Number (toIntegerMaybe -> Just t)) (Null ) (Number r) = return $ MissingValue t (toDouble r)+toTarget o (Number (toIntegerMaybe -> Just t)) (Number v) (Null ) = return $ MissingRate t (toDouble v)+toTarget o _ _ _ = typeMismatch "target: two out of three values of [goal date,value,rate]" o++instance FromJSON Target where+ parseJSON o@(Array vs) = case Vector.toList vs of+ [t, v, r] -> toTarget o t v r+ _ -> typeMismatch "target: two out of three values of [goal date,value,rate]" o+ parseJSON o = typeMismatch "target (array)" o++data Contract+ = Free+ | Pledge { cPledge :: Integer }+ | Stepdown { cPledge :: Integer, cAt :: Integer }+ deriving (Eq, Ord, Show, Read)++instance FromJSON Contract where+ parseJSON o@(Object v) = stepdown <|> pledge where+ stepdown = Stepdown <$> v .: "amount" <*> v .: "stepdown_at"+ pledge = Pledge <$> v .: "amount"+ parseJSON Null = pure Free+ parseJSON o = typeMismatch "contract (object)" o++-- TODO: Goals don't match the spec: they have an "id", "graphsum", and "rah"+-- fields. I wonder what they're for!+data Goal = Goal+ { gID :: Text+ , gGoal :: Text+ , gUpdatedAt :: Integer+ , gBurner :: Burner+ , gTitle :: Text+ , gTarget :: Target+ , gRatePeriod :: TimeFrame+ , gGraph :: Text -- ^ URL of graph image TODO: can this be computed from gID?+ , gThumb :: Text -- ^ URL of graph thumb TODO: can this be computed from gID?+ , gLoseDate :: Integer -- ^ assuming no more data reported+ , gPanic :: Double -- ^ how many seconds before 'gLoseDate' to FREAK OUT+ , gQueued :: Bool -- ^ is graph still rendering?+ , gPoints :: [Point] -- ^ empty unless you explicitly ask for it not to be+ , gPointCount :: Integer+ , gPledge :: Integer+ , gStartDate :: Integer+ , gStartValue :: Double+ , gCurrentDate :: Integer+ , gCurrentValue :: Double+ , gReportedDate :: Integer+ , gYaw :: Direction -- ^ which side of the road is good?+ , gSlope :: Direction -- ^ which way is the road going? TODO: can this be inferred from gRate? (what happens when a downward-sloping graph gets dialed to an upward slope?)+ , gLane :: Integer+ , gMathIsHard :: (Integer, Double, Double) -- ^ date, value, and rate??? TODO: can this be inferred from gTarget (or vice versa)? if not, what's the difference??+ , gSummary :: (Text, Text, Text) -- headsum, limsum, graphsum+ , gWon :: Bool -- TODO: can this be inferred from current date, gDate, and gLoseDate?+ , gFrozen :: Bool -- TODO: is this gWon || gLost?+ , gLost :: Bool -- TODO: can this be inferred from current date, gDate, and gLoseDate? (what happens in the grace period?)+ , gContract :: Contract -- ^ the current pledge (TODO: can this be inferred from gPledge or vice versa?) and the date of a scheduled future stepdown, if any+ , gRoad :: [Target]+ , gAggregate :: Aggregate -- ^ what to do with multiple points on a given day+ , gBehavior :: Set Behavior+ } deriving (Eq, Ord, Show, Read)++-- TODO: lens instances for Goal++instance FromJSON Goal where+ parseJSON o@(Object v) = Goal+ <$> v .: "id"+ <*> v .: "slug"+ <*> v .: "updated_at"+ <*> v .: "burner"+ <*> v .: "title"+ <*> join (liftA3 (toTarget o) (v .: "goaldate") (v .: "goalval") (v .: "rate"))+ <*> v .: "runits"+ <*> v .: "graph_url"+ <*> v .: "thumb_url"+ <*> v .: "losedate"+ <*> v .: "panic"+ <*> v .: "queued"+ <*> (v .: "datapoints" <|> pure [])+ <*> v .: "numpts"+ <*> v .: "pledge"+ <*> v .: "initday"+ <*> v .: "initval"+ <*> v .: "curday"+ <*> v .: "curval"+ <*> v .: "lastday"+ <*> v .: "yaw"+ <*> v .: "dir"+ <*> v .: "lane"+ <*> v .: "mathishard"+ <*> liftA3 (,,) (v .: "headsum") (v .: "limsum") (v .: "graphsum")+ <*> v .: "won"+ <*> v .: "frozen"+ <*> v .: "lost"+ <*> v .: "contract"+ <*> v .: "road"+ <*> v .: "aggday"+ <*> parseBehaviorSet v+ parseJSON o = typeMismatch "goal (object)" o++data GoalType = Hustler | Biker | FatLoser | Gainer | Inboxer | Drinker deriving (Eq, Ord, Show, Read, Bounded, Enum)+instance Default GoalType where def = minBound++-- hustler biker fatloser gainer inboxer drinker+-- yaw 1 1 -1 1 -1 -1+-- dir 1 1 -1 1 -1 1+-- exprd false false false false false false+-- kyoom true false false false false true+-- odom false true false false false false+-- edgy false false false false false true+-- noisy false false true true false false+-- aggday all all min last min all+-- steppy true true false false true true+-- rosy false false true true false false+-- movingav false false true true false false+-- aura false false true true false false+gType :: Goal -> Maybe GoalType+gType g = case (gYaw g, gSlope g, gAggregate g, mungeBehavior g) of+ (Up , Up , All , [Cumulative, StepLine] ) -> Just Hustler+ (Up , Up , All , [Odometer, StepLine] ) -> Just Biker+ (Down, Down, Min , [Noisy, Rosy, MovingAverage, Aura]) -> Just FatLoser+ (Up , Up , Last, [Noisy, Rosy, MovingAverage, Aura]) -> Just Gainer+ (Down, Down, Min , [StepLine] ) -> Just Inboxer+ (Down, Up , All , [Cumulative, Edgy, StepLine] ) -> Just Drinker+ _ -> Nothing+ where+ mungeBehavior = filter (`notElem` [Secret, SecretPoints]) . Set.toAscList . gBehavior++-- | You will not like the '_Goal' you get from the 'Default' instance. The+-- 'Goal' you get will have @_Points = []@ unless you explicitly ask for the+-- points by setting '_GetPoints'.+data GoalParameters = GoalParameters+ { gpUsername :: Maybe Text+ , gpGoal :: Text+ , gpGetPoints :: Bool+ } deriving (Eq, Ord, Show, Read)++instance Default GoalParameters where def = GoalParameters def def False++instance HasUsername GoalParameters where _Username = lens gpUsername (\s b -> s { gpUsername = b })+instance HasGoal GoalParameters where _Goal = lens gpGoal (\s b -> s { gpGoal = b })+instance HasGetPoints GoalParameters where _GetPoints = lens gpGetPoints (\s b -> s { gpGetPoints = b })++goal :: Token -> GoalParameters -> Request+goal t p = baseReq t ["users", maybeMe p, "goals", view _Goal p]+ & [("datapoints", "true") | view _GetPoints p]++data AllGoalsParameters = AllGoalsParameters+ { agpUsername :: Maybe Text+ , agpGoalsFilter :: Maybe Burner+ } deriving (Eq, Ord, Show, Read)++instance Default AllGoalsParameters where def = AllGoalsParameters def def++instance HasUsername AllGoalsParameters where _Username = lens agpUsername (\s b -> s { agpUsername = b })+instance HasGoalsFilter AllGoalsParameters where _GoalsFilter = lens agpGoalsFilter (\s b -> s { agpGoalsFilter = b })++allGoals :: Token -> AllGoalsParameters -> Request+allGoals t p = baseReq t ["users", maybeMe p, "goals"]+ & [("filter", lowerShow b <> "burner") | Just b <- [view _GoalsFilter p]]++-- | You will not like the '_Goal' you get from the 'Default' instance, and+-- you almost certainly will also not like the '_Title', '_Type', or '_Target'+-- you get. The only behaviors that will be respected in the '_Behavior' are+-- 'Ephemeral', 'Secret', and 'SecretPoints'; all the remaining behaviors will+-- be set according to the '_Type'.+data CreateGoalParameters = CreateGoalParameters+ { cgpUsername :: Maybe Text+ , cgpGoal :: Text+ , cgpTitle :: Text+ , cgpType :: GoalType+ , cgpTarget :: Target+ , cgpValue :: Double+ , cgpBehavior :: Set Behavior+ , cgpPanic :: Double+ } deriving (Eq, Ord, Show, Read)++-- given in the spec; this is 15 hours+defaultPanic = 54000++instance Default CreateGoalParameters where def = CreateGoalParameters def def def def (MissingDate 1 1) def (Set.singleton SecretPoints) defaultPanic++instance HasUsername CreateGoalParameters where _Username = lens cgpUsername (\s b -> s { cgpUsername = b })+instance HasGoal CreateGoalParameters where _Goal = lens cgpGoal (\s b -> s { cgpGoal = b })+instance HasTitle CreateGoalParameters where _Title = lens cgpTitle (\s b -> s { cgpTitle = b })+instance HasType CreateGoalParameters where _Type = lens cgpType (\s b -> s { cgpType = b })+instance HasTarget CreateGoalParameters where _Target = lens cgpTarget (\s b -> s { cgpTarget = b })+instance HasValue CreateGoalParameters where _Value = lens cgpValue (\s b -> s { cgpValue = b })+instance HasBehavior CreateGoalParameters where _Behavior = lens cgpBehavior (\s b -> s { cgpBehavior = b })+instance HasPanic CreateGoalParameters where _Panic = lens cgpPanic (\s b -> s { cgpPanic = b })++createGoal :: Token -> CreateGoalParameters -> Request+createGoal t p = urlEncodedBodyText (+ [ ("slug" , view _Goal $ p)+ , ("title" , view _Title $ p)+ , ("goal_type" , lowerShow . view _Type $ p)+ , ("initval" , lowerShow . view _Value $ p)+ , ("ephem" , lowerShow . Set.member Ephemeral . view _Behavior $ p)+ , ("panic" , lowerShow . view _Panic $ p)+ , ("secret" , lowerShow . Set.member Secret . view _Behavior $ p)+ , ("datapublic", lowerShow . Set.notMember SecretPoints . view _Behavior $ p)+ , ("dryrun" , "false") -- TODO: delete+ ]+ ++ renderTarget (view _Target p)+ )+ (baseReq t ["users", maybeMe p, "goals"])+ where+ renderTarget (MissingDate v r) = [ ("goalval", lowerShow v), ("rate", lowerShow r)]+ renderTarget (MissingValue t r) = [("goaldate", lowerShow t), ("rate", lowerShow r)]+ renderTarget (MissingRate t v ) = [("goaldate", lowerShow t), ("goalval", lowerShow v) ]++data Point = Point+ { pTimestamp :: Integer+ , pValue :: Double+ , pComment :: Text+ , pRequestID :: Maybe Text+ , pID :: Text+ , pUpdatedAt :: Integer+ } deriving (Eq, Ord, Show, Read)++instance HasTimestamp Point where _Timestamp = lens pTimestamp (\s b -> s { pTimestamp = b })+instance HasValue Point where _Value = lens pValue (\s b -> s { pValue = b })+instance HasComment Point where _Comment = lens pComment (\s b -> s { pComment = b })+instance HasRequestID Point where _RequestID = lens pRequestID (\s b -> s { pRequestID = b })+instance HasID Point where _ID = lens pID (\s b -> s { pID = b })+instance HasUpdatedAt Point where _UpdatedAt = lens pUpdatedAt (\s b -> s { pUpdatedAt = b })++instance FromJSON Point where+ parseJSON o@(Object v) = Point+ <$> v .: "timestamp"+ <*> v .: "value"+ <*> v .: "comment"+ <*> v .: "requestid"+ <*> v .: "id"+ <*> v .: "updated_at"+ parseJSON o = typeMismatch "point" o++-- | You will not like the '_Goal' you get from the 'Default' instance.+data PointsParameters = PointsParameters+ { ppUsername :: Maybe Text+ , ppGoal :: Text+ } deriving (Eq, Ord, Show, Read)++instance Default PointsParameters where def = PointsParameters def def++instance HasUsername PointsParameters where _Username = lens ppUsername (\s b -> s { ppUsername = b })+instance HasGoal PointsParameters where _Goal = lens ppGoal (\s b -> s { ppGoal = b })++points :: Token -> PointsParameters -> Request+points t p = baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints"]++-- | You will not like the '_Timestamp' or '_Value' you get from the+-- 'Default' instance. You may like 'now'.+data PointRequest = PointRequest+ { prTimestamp :: Integer+ , prValue :: Double+ , prComment :: Text+ , prRequestID :: Maybe Text+ } deriving (Eq, Ord, Show, Read)++instance Default PointRequest where def = PointRequest def def def def++instance HasTimestamp PointRequest where _Timestamp = lens prTimestamp (\s b -> s { prTimestamp = b })+instance HasValue PointRequest where _Value = lens prValue (\s b -> s { prValue = b })+instance HasComment PointRequest where _Comment = lens prComment (\s b -> s { prComment = b })+instance HasRequestID PointRequest where _RequestID = lens prRequestID (\s b -> s { prRequestID = b })++instance ToJSON PointRequest where+ toJSON p = object $+ [ "timestamp" .= view _Timestamp p+ , "value" .= view _Value p+ , "comment" .= view _Comment p+ ] +++ [ "requestid" .= requestid | Just requestid <- [view _RequestID p]]++-- | Set the timestamp to the current time.+now :: (MonadIO m, HasTimestamp a) => a -> m a+now a = liftIO $ flip (set _Timestamp) a . round <$> getPOSIXTime++-- TODO: perhaps we shouldn't have separate createPoint and createPoints! After+-- all, the latter completely subsumes the former, and we can internally check+-- the length of the list to decide what to do if the single-point creation API+-- call turns out to be better for some reason.++-- | You will not like the '_Goal', '_Timestamp', or '_Value' you get from the+-- 'Default' instance. You may like 'now'.+data CreatePointParameters = CreatePointParameters+ { cppUsername :: Maybe Text+ , cppGoal :: Text+ , cppPointRequest :: PointRequest+ } deriving (Eq, Ord, Show, Read)++instance Default CreatePointParameters where def = CreatePointParameters def def def++instance HasUsername CreatePointParameters where _Username = lens cppUsername (\s b -> s { cppUsername = b })+instance HasGoal CreatePointParameters where _Goal = lens cppGoal (\s b -> s { cppGoal = b })+instance HasPointRequest CreatePointParameters where _PointRequest = lens cppPointRequest (\s b -> s { cppPointRequest = b })+instance HasTimestamp CreatePointParameters where _Timestamp = _PointRequest . _Timestamp+instance HasValue CreatePointParameters where _Value = _PointRequest . _Value+instance HasComment CreatePointParameters where _Comment = _PointRequest . _Comment+instance HasRequestID CreatePointParameters where _RequestID = _PointRequest . _RequestID++-- | You will not like the '_Goal' or '_PointRequests' you get from the+-- 'Default' instance.+data CreatePointsParameters = CreatePointsParameters+ { cpspUsername :: Maybe Text+ , cpspGoal :: Text+ , cpspPointRequests :: [PointRequest]+ } deriving (Eq, Ord, Show, Read)++instance Default CreatePointsParameters where def = CreatePointsParameters def def def++instance HasUsername CreatePointsParameters where _Username = lens cpspUsername (\s b -> s { cpspUsername = b })+instance HasGoal CreatePointsParameters where _Goal = lens cpspGoal (\s b -> s { cpspGoal = b })+instance HasPointRequests CreatePointsParameters where _PointRequests = lens cpspPointRequests (\s b -> s { cpspPointRequests = b })++createPoint , createPointNotify :: Token -> CreatePointParameters -> Request+createPoints, createPointsNotify :: Token -> CreatePointsParameters -> Request++createPointNotify = createPointInternal True+createPoint = createPointInternal False++tsvcArgs p =+ [ ("timestamp", (textShow . view _Timestamp) p)+ , ("value" , (textShow . view _Value ) p)+ , ("comment" , ( view _Comment ) p)+ ]++createPointInternal sendmail t p = urlEncodedBodyText+ ( tsvcArgs p+ ++ [("requestid", r) | Just r <- [view _RequestID p]]+ ++ [("sendmail" , "true") | sendmail]+ )+ -- TODO: unify with the other occurrence of users/me/goals/goal-name/datapoints+ (baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints"])++createPointsNotify = createPointsInternal True+createPoints = createPointsInternal False++createPointsInternal sendmail t p = urlEncodedBody+ ([("datapoints", toStrict . encode . view _PointRequests $ p)] +++ [("sendmail" , "true") | sendmail]+ )+ (baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints", "create_all"])++-- | You will not like the '_Goal', '_ID', '_Timestamp', or '_Value' you get+-- from the 'Default' instance. You may like 'now'.+data UpdatePointParameters = UpdatePointParameters+ { uppUsername :: Maybe Text+ , uppGoal :: Text+ , uppID :: Text+ , uppTimestamp :: Integer+ , uppValue :: Double+ , uppComment :: Text+ } deriving (Eq, Ord, Show, Read)++instance Default UpdatePointParameters where def = UpdatePointParameters def def def def def def++instance HasUsername UpdatePointParameters where _Username = lens uppUsername (\s b -> s { uppUsername = b })+instance HasGoal UpdatePointParameters where _Goal = lens uppGoal (\s b -> s { uppGoal = b })+instance HasID UpdatePointParameters where _ID = lens uppID (\s b -> s { uppID = b })+instance HasTimestamp UpdatePointParameters where _Timestamp = lens uppTimestamp (\s b -> s { uppTimestamp = b })+instance HasValue UpdatePointParameters where _Value = lens uppValue (\s b -> s { uppValue = b })+instance HasComment UpdatePointParameters where _Comment = lens uppComment (\s b -> s { uppComment = b })++updatePoint :: Token -> UpdatePointParameters -> Request+updatePoint t p = (urlEncodedBodyText+ (tsvcArgs p)+ (baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints", view _ID p])+ ) { method = "PUT" }++-- TODO: is there some commonality that we can pull out from this and other parameters data types??+-- | You will not like the '_Goal' or '_ID' you get from the 'Default'+-- instance.+data DeletePointParameters = DeletePointParameters+ { dppUsername :: Maybe Text+ , dppGoal :: Text+ , dppID :: Text+ } deriving (Eq, Ord, Show, Read)++instance Default DeletePointParameters where def = DeletePointParameters def def def++instance HasUsername DeletePointParameters where _Username = lens dppUsername (\s b -> s { dppUsername = b })+instance HasGoal DeletePointParameters where _Goal = lens dppGoal (\s b -> s { dppGoal = b })+instance HasID DeletePointParameters where _ID = lens dppID (\s b -> s { dppID = b })++deletePoint :: Token -> DeletePointParameters -> Request+deletePoint t p = (baseReq t ["users", maybeMe p, "goals", view _Goal p, "datapoints", view _ID p]) { method = "DELETE" }+-- Finite instances {{{+instance Universe Burner where universe = universeDef+instance Universe TimeFrame where universe = universeDef+instance Universe Aggregate where universe = universeDef+instance Universe Direction where universe = universeDef+instance Universe Behavior where universe = universeDef+instance Universe GoalType where universe = universeDef+instance Finite Burner+instance Finite TimeFrame+instance Finite Aggregate+instance Finite Direction+instance Finite Behavior+instance Finite GoalType+-- }}}
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ beeminder-api.cabal view
@@ -0,0 +1,53 @@+name: beeminder-api+version: 1.0+synopsis: Bindings to the beeminder.com JSON API+description: <<https://www.beeminder.com/images/logo_hi.png>>+ .+ <http://beeminder.com> is a tool for incentivizing yourself to+ accomplish your quantifiable goals. This package+ provides Haskell bindings to beeminder's JSON API.+license: BSD3+license-file: LICENSE+author: Daniel Wagner+maintainer: greenrd@greenrd.org+bug-reports: http://github.com/greenrd/beeminder-api/issues+copyright: Copyright (C) 2013 Daniel Wagner+category: Network+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: http://github.com/greenrd/beeminder-api.git++library+ exposed-modules: Network.Beeminder+ other-modules: Network.Beeminder.Internal,+ Data.Aeson.Encode.Shim+ build-depends:+ base >= 4.5 && < 4.10,+ mtl >= 2.1 && < 2.3,+ aeson >= 0.7 && < 1.1,+ scientific >= 0.3 && < 0.4,+ attoparsec >= 0.10 && < 0.14,+ conduit >= 0.5 && < 1.3,+ data-default-class ==0.0.*,+ data-default-instances-base ==0.0.*,+ http-conduit >= 2 && < 2.2,+ vector >= 0.10 && < 0.11,+ containers >= 0.5 && < 0.6,+ unordered-containers >= 0.2.3 && < 0.3,+ bytestring >= 0.10 && < 0.11,+ blaze-builder >= 0.3 && < 0.5,+ http-types >= 0.8 && < 0.9,+ universe >= 1.0 && < 1.1,+ universe-base >= 1.0 && < 1.1,+ time >= 1.4 && < 1.6,+ text >= 0.11 && < 1.3,+ transformers >= 0.3 && < 0.6,+ transformers-base >= 0.4 && < 0.5,+ lens >= 3.9 && < 4.15,+ monad-control >= 0.3 && < 1.1,+ resourcet >= 1.1 && < 1.2++ default-language: Haskell2010