import Data.ByteString.Char8 as B

eventTypeParser :: FieldParser EventType

eventTypeParser :: FieldParser (C.UTCTime -> LogEvent)

    "event_t" -> maybe (returnError UnexpectedNull f "") (nameEvent . decodeUtf8) v
    _         -> returnError Incompatible f "column was not of type event_t"

    "event_t" -> 
      let err = UnexpectedNull (B.unpack tn)
                               (tableOid f) 
                               (maybe "" B.unpack (name f))
                               "UTCTime -> LogEvent"
                               "columns of type event_t should not contain null values"
      in  maybe (conversionError err) (nameEvent . decodeUtf8) v
    _ -> 
      let err = Incompatible (B.unpack tn)
                             (tableOid f) 
                             (maybe "" B.unpack (name f))
                             "UTCTime -> LogEvent"
                             "column was not of type event_t"
      in conversionError err

workEventParser :: RowParser WorkEvent
workEventParser = WorkEvent <$> fieldWith eventTypeParser <*> fieldWith utcParser <*> field

workEventParser :: RowParser LogEvent
workEventParser = fieldWith eventTypeParser <*> fieldWith utcParser

logEntryParser  = LogEntry <$> fieldWith btcAddrParser <*> workEventParser 

logEntryParser  = LogEntry <$> fieldWith btcAddrParser <*> workEventParser <*> field

recordEvent' (ProjectId pid) (UserId uid) (LogEntry a e) = do 

recordEvent' (ProjectId pid) (UserId uid) (LogEntry a e m) = do 

    , e ^. (eventType . to eventName)
    , fromThyme $ e ^. eventTime
    , e ^. eventMeta

    , eventName e
    , fromThyme $ eventTime e
    , m

  , btcAddr, event
  , EventType(..)

  , btcAddr, event, eventMeta
  , LogEvent(..)

  , WorkEvent(..)
  , eventType, eventTime, eventMeta

data EventType = StartWork | StopWork deriving (Show, Eq, Typeable)

data LogEvent = StartWork { eventTime :: C.UTCTime }
              | StopWork  { eventTime :: C.UTCTime }
              deriving (Show, Eq)
makePrisms ''LogEvent

instance Ord EventType where
  compare StartWork StopWork = GT
  compare StopWork StartWork = LT
  compare _ _ = EQ

instance Ord LogEvent where
  compare (StartWork t0) (StopWork  t1) = if t0 == t1 then GT else compare t0 t1
  compare (StopWork  t0) (StartWork t1) = if t0 == t1 then LT else compare t0 t1
  compare (StartWork t0) (StartWork t1) = compare t0 t1
  compare (StopWork  t0) (StopWork  t1) = compare t0 t1

eventName :: EventType -> Text
eventName StartWork = "start"
eventName StopWork  = "stop"

eventName :: LogEvent -> Text
eventName (StartWork _) = "start"
eventName (StopWork  _) = "stop"

nameEvent :: MonadPlus m => Text -> m EventType

nameEvent :: MonadPlus m => Text -> m (C.UTCTime -> LogEvent)

data WorkEvent = WorkEvent 
  { _eventType :: EventType
  , _eventTime :: C.UTCTime
  -- Permit the inclusion of arbitrary JSON data that may be refactored into
  -- proper typed fields in the future. 
  , _eventMeta :: Maybe A.Value
  } deriving (Show, Eq)
makeLenses ''WorkEvent
instance Ord WorkEvent where
  compare a b = 
    let cv x = (x ^. eventTime, x ^. eventType)
    in compare (cv a) (cv b)

  , _event :: WorkEvent 

  , _event   :: LogEvent 
  , _eventMeta :: Maybe A.Value

    let ordElems e = (e ^. (event.eventTime), e ^. (event.eventType), e ^. btcAddr)

    let ordElems e = (e ^. event, e ^. btcAddr)

type RawIndex = Map BtcAddr [Either WorkEvent Interval]
type NDT = C.NominalDiffTime

type NDT = C.NominalDiffTime

{-|
 - The values of the raw index map are either complete intervals (which may be
 - extended if a new start is encountered at the same instant as the end of the
 - interval) or start events awaiting completion.
 -}
type RawIndex = Map BtcAddr [Either LogEvent Interval]

appendLogEntry idx (LogEntry k ev) = 
  let combine (WorkEvent StartWork t _) (WorkEvent StopWork t' _)  | t' > t = Right $ Interval t t'
      combine (e1 @ (WorkEvent StartWork _ _)) (e2 @ (WorkEvent StartWork _ _)) = Left $ max e1 e2
      combine (e1 @ (WorkEvent StopWork  _ _)) (e2 @ (WorkEvent StopWork  _ _)) = Left $ min e1 e2

appendLogEntry idx (LogEntry k ev _) = 
  let combine (StartWork t) (StopWork t') | t' > t = Right $ Interval t t'
      combine (e1 @ (StartWork _)) (e2 @ (StartWork _)) = Left $ min e1 e2 -- ignore redundant starts
      combine (e1 @ (StopWork  _)) (e2 @ (StopWork  _)) = Left $ min e1 e2 -- ignore redundant ends

      -- if the interval includes the timestamp of a start event, then allow the extension of the interval
      extension :: Interval -> LogEvent -> Maybe LogEvent
      extension ival (StartWork t) | containsInclusive t ival = Just $ StartWork (ival ^. start)
      extension _ _ = Nothing

        -- if it is possible to extend an interval at the top of the stack
        -- because the end of that interval is the same 
        Just (Right ival : xs) -> case extension ival ev of
          Just e' -> Left e' : xs
          Nothing -> Left ev : Right ival : xs
        -- if the top element of the stack is not an interval

        Just xs -> Left ev : xs
        Nothing -> Left ev : []

        _ -> Left ev : []

 -

logWorkHandler :: EventType -> Handler App App EventId
logWorkHandler evType = do 

logWorkHandler :: (C.UTCTime -> LogEvent) -> Handler App App EventId
logWorkHandler evCtr = do 

  let workEvent = WorkEvent evType timestamp $ A.decode requestBody
      storeEv addr = runReaderT . recordEvent pid uid $ LogEntry addr workEvent

  let logEntry addr = LogEntry addr (evCtr timestamp) (A.decode requestBody)
      storeEv addr = runReaderT . recordEvent pid uid $ logEntry addr

import Data.List.NonEmpty as L 
import Data.Map.Strict as M

import qualified Data.List.NonEmpty as L 
import qualified Data.Map.Strict as M

instance Arbitrary EventType where
  arbitrary = elements [StartWork, StopWork]
newtype EventLog = EventLog [LogEntry]

newtype Intervals = Intervals (L.NonEmpty Interval)
buildIntervals :: T.UTCTime -> [NominalDiffTime] -> [Interval]
buildIntervals t (d : s : dx) = 
  let ival = I.interval t (t .+^ d) 
  in  ival : buildIntervals (ival ^. end .+^ (abs s)) dx
buildIntervals _ _ = []
instance Arbitrary Intervals where
  arbitrary = do
    startTime <- arbitrary 
    let deltas = filter (> 0) <$> listOf arbitrary
    intervals <- suchThat (buildIntervals startTime <$> deltas) (not.null)
    pure . Intervals $ L.fromList intervals

    let record = (,) <$> arbitrary <*> (L.fromList <$> listOf1 arbitrary)

    let record = do addr <- arbitrary 
                    Intervals ivals <- arbitrary
                    pure (addr, ivals)

            [ parseISO8601 "2014-01-01T00:12:00Z"

            [ parseISO8601 "2014-01-01T00:11:59Z"

            LogEntry addr <$> [WorkEvent StartWork start' Nothing, WorkEvent StopWork end' Nothing]

            LogEntry addr <$> [StartWork start', StopWork end'] <*> [Nothing]

          expected' = fromListWith (<>) $ fmap (second pure) testIntervals

          expected' = M.fromListWith (<>) $ fmap (second pure) testIntervals

        let ivalEntries addr ival = [ LogEntry addr (WorkEvent StartWork (ival ^. start) Nothing)
                                    , LogEntry addr (WorkEvent StopWork  (ival ^. end) Nothing) ]

        let ivalEntries addr ival = LogEntry addr <$> [StartWork (ival ^. start), StopWork (ival ^. end)]
                                                  <*> [Nothing]

            logEntries = foldrWithKey acc [] widx

            logEntries = M.foldrWithKey acc [] widx

  describe "EventType serialization" $ do
    it "serialization is invertible" $ property $
      \e -> (nameEvent . eventName) e == Just e