1 {-# LANGUAGE OverloadedStrings #-}
    2 module Databrary.Controller.IdSet
    3   ( IdSet
    4   , idSetIsFull
    5   , requestIdSet
    6   , idSetQuery
    7   ) where
    8 
    9 import qualified Data.ByteString.Char8 as BSC
   10 import Data.List (foldl')
   11 import Data.Maybe (mapMaybe)
   12 import qualified Data.RangeSet.List as RS
   13 import qualified Data.RangeSet.Parse as RS
   14 import Network.HTTP.Types (Query)
   15 import qualified Network.Wai as Wai
   16 
   17 import Databrary.Model.Id.Types
   18 
   19 type IdSet a = RS.RSet (Id a)
   20 
   21 idSetIsFull :: (Eq (IdType a), Bounded (IdType a)) => IdSet a -> Bool
   22 idSetIsFull = (==) RS.full
   23 
   24 requestIdSet :: (Read (IdType a), Ord (IdType a), Enum (IdType a), Bounded (IdType a)) => Wai.Request -> IdSet a
   25 requestIdSet = pe . mapMaybe ie . Wai.queryString where
   26   pe [] = RS.full
   27   pe (h:l) = foldl' ae (either RS.complement id h) l
   28   ae s (Right i) = s `RS.union` i
   29   ae s (Left e) = s `RS.difference` e
   30   ie (k, Nothing) = Right <$> ps k
   31   ie (k, Just v)
   32     | k `BSC.isPrefixOf` "include" = Right <$> ps v
   33     | k `BSC.isPrefixOf` "exclude" = Left <$> ps v
   34   ie _ = Nothing
   35   ps = RS.parseRangeSet . BSC.unpack
   36 
   37 idSetQuery :: (Show (IdType a), Ord (IdType a), Enum (IdType a), Bounded (IdType a)) => IdSet a -> Query
   38 idSetQuery s
   39   | idSetIsFull s = []
   40   | RS.findMin s == minBound = vs "exclude" $ RS.complement s
   41   | otherwise = vs "include" s where
   42   vs ie = return . (,) ie . Just . BSC.pack . RS.showRangeSet