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)