diff --git a/Data/Aeson/Encode/Shim.hs b/Data/Aeson/Encode/Shim.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/Encode/Shim.hs @@ -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 +-- +-- 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 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 <> diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Beeminder.hs b/Network/Beeminder.hs new file mode 100644 --- /dev/null +++ b/Network/Beeminder.hs @@ -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 diff --git a/Network/Beeminder/Internal.hs b/Network/Beeminder/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Beeminder/Internal.hs @@ -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 +-- }}} diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/beeminder-api.cabal b/beeminder-api.cabal new file mode 100644 --- /dev/null +++ b/beeminder-api.cabal @@ -0,0 +1,53 @@ +name: beeminder-api +version: 1.0 +synopsis: Bindings to the beeminder.com JSON API +description: <> + . + 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