1 {-# LANGUAGE OverloadedStrings, TypeOperators #-}
    2 module Databrary.Controller.Paths
    3   ( pathId
    4   , PartyTarget(..)
    5   , pathPartyTarget
    6   , AuthorizeTarget(..)
    7   , pathAuthorizeTarget
    8   , VolumeAccessTarget(..)
    9   , pathVolumeAccessTarget
   10   , pathSegment
   11   , pathSlotId
   12   , TagId(..)
   13   , pathTagId
   14   ) where
   15 
   16 import qualified Data.Invertible as I
   17 import Data.String (fromString)
   18 import qualified Web.Route.Invertible as R
   19 import Web.Route.Invertible (Parameter, PathString)
   20 -- import Servant
   21 
   22 import Databrary.Model.Kind
   23 import Databrary.Model.Id.Types
   24 import Databrary.Model.Party.Types
   25 import Databrary.Model.Container.Types
   26 import Databrary.Model.Segment
   27 import Databrary.Model.Slot.Types
   28 import Databrary.Model.Tag.Types
   29 -- import Databrary.HTTP.Path
   30 import Databrary.HTTP.Path.Parser
   31 
   32 type PathParameter = Parameter PathString
   33 
   34 idIso :: IdType a I.<-> Id a
   35 idIso = -- [I.biCase|a <-> Id a|]
   36     ((\a      -> Id a)
   37      R.:<->:
   38      (\(Id a) -> a))
   39 
   40 pathIdWith :: forall a . (Kinded a) => PathParser (IdType a) -> PathParser (Id a)
   41 pathIdWith p = fromString (kindOf (undefined :: a)) >/> idIso >$< p
   42 
   43 pathId :: forall a . (PathParameter (IdType a), Kinded a) => PathParser (Id a)
   44 pathId = pathIdWith R.parameter
   45 
   46 -- | The target party for some action?
   47 data PartyTarget
   48   = TargetProfile -- ^ Actor's own party
   49   | TargetParty (Id Party) -- ^ Someone else's party
   50 
   51 -- | Typical examples of pathPartyTarget:
   52 -- /profile becomes TargetProfile
   53 -- /party/10 becomes TargetParty (Id 10)
   54 pathPartyTarget :: R.Path PartyTarget
   55 pathPartyTarget = -- [I.biCase|
   56   --   Left () <-> TargetProfile
   57   --   Right i <-> TargetParty i
   58   --  |]
   59     ((\p -> case p of
   60         Left ()       -> TargetProfile
   61         Right i       -> TargetParty i)
   62      R.:<->:
   63      (\r -> case r of
   64         TargetProfile -> Left ()
   65         TargetParty i -> Right i))
   66   >$< ("profile" |/| pathId)
   67 
   68 -- | This is a trailing part of connection between two parties. For a given party, the second
   69 -- party mentioned as the target here is either the parent that the child is applying to such as
   70 -- ((TargetParty currentUserAsChildId), (AuthorizeTarget True parentId))
   71 -- or the child that the parent has authorized
   72 -- ((TargetParty currentUserAsParentId), (AuthorizeTarget False childId))
   73 data AuthorizeTarget = AuthorizeTarget
   74   { authorizeApply :: Bool -- ^ Whether this authorize action is referring to applying from a child to a parent
   75   , authorizeTarget :: Id Party
   76   }
   77 
   78 pathAuthorizeTarget :: PathParser AuthorizeTarget
   79 pathAuthorizeTarget = -- [I.biCase|(a, t) <-> AuthorizeTarget a t|]
   80   ((\(a, t)                -> AuthorizeTarget a t)
   81    R.:<->:
   82    (\(AuthorizeTarget a t) -> (a, t)))
   83     >$<
   84       (I.isRight >$< ("authorize" |/| "apply")
   85        </> idIso >$< R.parameter)
   86 
   87 newtype VolumeAccessTarget = VolumeAccessTarget
   88   { volumeAccessTarget :: Id Party
   89   }
   90 
   91 pathVolumeAccessTarget :: PathParser VolumeAccessTarget
   92 pathVolumeAccessTarget =
   93   "access"
   94   >/> -- [I.biCase|i <-> VolumeAccessTarget (Id i)|]
   95     ((\i                           -> VolumeAccessTarget (Id i))
   96      R.:<->:
   97      (\(VolumeAccessTarget (Id i)) -> i))
   98   >$< R.parameter
   99 
  100 slotIdIso :: (Id Container, Segment) I.<-> SlotId
  101 slotIdIso = -- [I.biCase|(c, s) <-> SlotId c s|]
  102     ((\(c, s)       -> SlotId c s)
  103      R.:<->:
  104      (\(SlotId c s) -> (c, s)))
  105 
  106 pathSegment :: PathParser Segment
  107 pathSegment = fullSegment =/= R.parameter
  108 
  109 pathSlot :: PathParser SlotId
  110 pathSlot = slotIdIso >$< (idIso >$< R.parameter </> pathSegment)
  111 
  112 pathSlotId :: PathParser (Id Slot)
  113 pathSlotId = pathIdWith pathSlot
  114 
  115 data TagId = TagId
  116   { tagIdKeyword :: Bool
  117   , tagIdName :: TagName
  118   }
  119 
  120 pathTagId :: PathParser TagId
  121 pathTagId = -- [I.biCase|(b, t) <-> TagId b t|]
  122   ((\(b, t)      -> TagId b t)
  123    R.:<->:
  124    (\(TagId b t) -> (b, t)))
  125   >$<
  126   (I.isRight >$< ("tag" |/| "keyword") </> R.parameter)