From 2b5fc33607720d0cccd7d8f9cb7232042ead73e6 Mon Sep 17 00:00:00 2001 From: foo Date: Sun, 22 Sep 2013 00:36:56 +0000 Subject: [PATCH] expand TH used the EvilSplicer + manual fix ups --- DAV.cabal | 20 +-- Network/Protocol/HTTP/DAV.hs | 73 ++++++----- Network/Protocol/HTTP/DAV/TH.hs | 196 +++++++++++++++++++++++++++- dist/build/HSDAV-0.4.1.o | Bin 140080 -> 0 bytes dist/build/Network/Protocol/HTTP/DAV.hi | Bin 34549 -> 57657 bytes dist/build/Network/Protocol/HTTP/DAV.o | Bin 160248 -> 201932 bytes dist/build/Network/Protocol/HTTP/DAV/TH.hi | Bin 17056 -> 18733 bytes dist/build/Network/Protocol/HTTP/DAV/TH.o | Bin 19672 -> 28120 bytes dist/build/autogen/Paths_DAV.hs | 18 ++- dist/build/autogen/cabal_macros.h | 45 +++---- dist/build/libHSDAV-0.4.1.a | Bin 200082 -> 260188 bytes dist/package.conf.inplace | 2 - dist/setup-config | 2 - 13 files changed, 266 insertions(+), 90 deletions(-) delete mode 100644 dist/build/HSDAV-0.4.1.o delete mode 100644 dist/package.conf.inplace delete mode 100644 dist/setup-config diff --git a/DAV.cabal b/DAV.cabal index 06b3a8b..90368c6 100644 --- a/DAV.cabal +++ b/DAV.cabal @@ -38,25 +38,7 @@ library , transformers >= 0.3 , xml-conduit >= 1.0 && <= 1.2 , xml-hamlet >= 0.4 && <= 0.5 -executable hdav - main-is: hdav.hs - ghc-options: -Wall - build-depends: base >= 4.5 && <= 5 - , bytestring - , bytestring - , case-insensitive >= 0.4 - , containers - , http-conduit >= 1.9.0 - , http-types >= 0.7 - , lens >= 3.0 - , lifted-base >= 0.1 - , mtl >= 2.1 - , network >= 2.3 - , optparse-applicative - , resourcet >= 0.3 - , transformers >= 0.3 - , xml-conduit >= 1.0 && <= 1.2 - , xml-hamlet >= 0.4 && <= 0.5 + , text source-repository head type: git diff --git a/Network/Protocol/HTTP/DAV.hs b/Network/Protocol/HTTP/DAV.hs index 8ffc270..d064a8f 100644 --- a/Network/Protocol/HTTP/DAV.hs +++ b/Network/Protocol/HTTP/DAV.hs @@ -28,12 +28,12 @@ module Network.Protocol.HTTP.DAV ( , deleteContent , moveContent , makeCollection - , caldavReport , module Network.Protocol.HTTP.DAV.TH ) where import Network.Protocol.HTTP.DAV.TH +import qualified Data.Text import Control.Applicative (liftA2) import Control.Exception.Lifted (catchJust, finally, bracketOnError) import Control.Lens ((.~), (^.)) @@ -200,11 +200,6 @@ props2patch = XML.renderLBS XML.def . patch . props . fromDocument , "{DAV:}supportedlock" ] -caldavReportM :: MonadResourceBase m => DAVState m XML.Document -caldavReportM = do - let ahs = [(hContentType, "application/xml; charset=\"utf-8\"")] - calrresp <- davRequest "REPORT" ahs (xmlBody calendarquery) - return $ (XML.parseLBS_ def . responseBody) calrresp getProps :: String -> B.ByteString -> B.ByteString -> Maybe Depth -> IO XML.Document getProps url username password md = withDS url username password md getPropsM @@ -246,9 +241,6 @@ moveContent :: String -> B.ByteString -> B.ByteString -> B.ByteString -> IO () moveContent url newurl username password = withDS url username password Nothing $ moveContentM newurl -caldavReport :: String -> B.ByteString -> B.ByteString -> IO XML.Document -caldavReport url username password = withDS url username password (Just Depth1) $ caldavReportM - -- | Creates a WebDAV collection, which is similar to a directory. -- -- Returns False if the collection could not be made due to an intermediate @@ -264,28 +256,45 @@ makeCollection url username password = withDS url username password Nothing $ propname :: XML.Document propname = XML.Document (XML.Prologue [] Nothing []) root [] where - root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) [xml| - -|] - + root = XML.Element "D:propfind" (Map.fromList [("xmlns:D", "DAV:")]) $ concat + [[XML.NodeElement + (XML.Element + (XML.Name + (Data.Text.pack "D:allprop") Nothing Nothing) + Map.empty + (concat []))]] locky :: XML.Document locky = XML.Document (XML.Prologue [] Nothing []) root [] - where - root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) [xml| - - - - -Haskell DAV user -|] - -calendarquery :: XML.Document -calendarquery = XML.Document (XML.Prologue [] Nothing []) root [] - where - root = XML.Element "C:calendar-query" (Map.fromList [("xmlns:D", "DAV:"),("xmlns:C", "urn:ietf:params:xml:ns:caldav")]) [xml| - - - - - -|] + where + root = XML.Element "D:lockinfo" (Map.fromList [("xmlns:D", "DAV:")]) $ concat + [[XML.NodeElement + (XML.Element + (XML.Name + (Data.Text.pack "D:lockscope") Nothing Nothing) + Map.empty + (concat + [[XML.NodeElement + (XML.Element + (XML.Name + (Data.Text.pack "D:exclusive") Nothing Nothing) + Map.empty + (concat []))]]))], + [XML.NodeElement + (XML.Element + (XML.Name + (Data.Text.pack "D:locktype") Nothing Nothing) + Map.empty + (concat + [[XML.NodeElement + (XML.Element + (XML.Name (Data.Text.pack "D:write") Nothing Nothing) + Map.empty + (concat []))]]))], + [XML.NodeElement + (XML.Element + (XML.Name (Data.Text.pack "D:owner") Nothing Nothing) + Map.empty + (concat + [[XML.NodeContent + (Data.Text.pack "Haskell DAV user")]]))]] + diff --git a/Network/Protocol/HTTP/DAV/TH.hs b/Network/Protocol/HTTP/DAV/TH.hs index 9fb3495..18b8df7 100644 --- a/Network/Protocol/HTTP/DAV/TH.hs +++ b/Network/Protocol/HTTP/DAV/TH.hs @@ -20,7 +20,8 @@ module Network.Protocol.HTTP.DAV.TH where -import Control.Lens (makeLenses) +import qualified Control.Lens.Type +import qualified Data.Functor import qualified Data.ByteString as B import Network.HTTP.Conduit (Manager, Request) @@ -46,4 +47,195 @@ data DAVContext a = DAVContext { , _basicpassword :: B.ByteString , _depth :: Maybe Depth } -makeLenses ''DAVContext +allowedMethods :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) [B.ByteString] +allowedMethods + _f_a5GM + (DAVContext __allowedMethods'_a5GN + __baseRequest_a5GP + __complianceClasses_a5GQ + __httpManager_a5GR + __lockToken_a5GS + __basicusername_a5GT + __basicpassword_a5GU + __depth_a5GV) + = ((\ __allowedMethods_a5GO + -> DAVContext + __allowedMethods_a5GO + __baseRequest_a5GP + __complianceClasses_a5GQ + __httpManager_a5GR + __lockToken_a5GS + __basicusername_a5GT + __basicpassword_a5GU + __depth_a5GV) + Data.Functor.<$> (_f_a5GM __allowedMethods'_a5GN)) +{-# INLINE allowedMethods #-} +baseRequest :: + Control.Lens.Type.Lens (DAVContext a_a4I4) (DAVContext a_a5GW) (Request a_a4I4) (Request a_a5GW) +baseRequest + _f_a5GX + (DAVContext __allowedMethods_a5GY + __baseRequest'_a5GZ + __complianceClasses_a5H1 + __httpManager_a5H2 + __lockToken_a5H3 + __basicusername_a5H4 + __basicpassword_a5H5 + __depth_a5H6) + = ((\ __baseRequest_a5H0 + -> DAVContext + __allowedMethods_a5GY + __baseRequest_a5H0 + __complianceClasses_a5H1 + __httpManager_a5H2 + __lockToken_a5H3 + __basicusername_a5H4 + __basicpassword_a5H5 + __depth_a5H6) + Data.Functor.<$> (_f_a5GX __baseRequest'_a5GZ)) +{-# INLINE baseRequest #-} +basicpassword :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) B.ByteString +basicpassword + _f_a5H7 + (DAVContext __allowedMethods_a5H8 + __baseRequest_a5H9 + __complianceClasses_a5Ha + __httpManager_a5Hb + __lockToken_a5Hc + __basicusername_a5Hd + __basicpassword'_a5He + __depth_a5Hg) + = ((\ __basicpassword_a5Hf + -> DAVContext + __allowedMethods_a5H8 + __baseRequest_a5H9 + __complianceClasses_a5Ha + __httpManager_a5Hb + __lockToken_a5Hc + __basicusername_a5Hd + __basicpassword_a5Hf + __depth_a5Hg) + Data.Functor.<$> (_f_a5H7 __basicpassword'_a5He)) +{-# INLINE basicpassword #-} +basicusername :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) B.ByteString +basicusername + _f_a5Hh + (DAVContext __allowedMethods_a5Hi + __baseRequest_a5Hj + __complianceClasses_a5Hk + __httpManager_a5Hl + __lockToken_a5Hm + __basicusername'_a5Hn + __basicpassword_a5Hp + __depth_a5Hq) + = ((\ __basicusername_a5Ho + -> DAVContext + __allowedMethods_a5Hi + __baseRequest_a5Hj + __complianceClasses_a5Hk + __httpManager_a5Hl + __lockToken_a5Hm + __basicusername_a5Ho + __basicpassword_a5Hp + __depth_a5Hq) + Data.Functor.<$> (_f_a5Hh __basicusername'_a5Hn)) +{-# INLINE basicusername #-} +complianceClasses :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) [B.ByteString] +complianceClasses + _f_a5Hr + (DAVContext __allowedMethods_a5Hs + __baseRequest_a5Ht + __complianceClasses'_a5Hu + __httpManager_a5Hw + __lockToken_a5Hx + __basicusername_a5Hy + __basicpassword_a5Hz + __depth_a5HA) + = ((\ __complianceClasses_a5Hv + -> DAVContext + __allowedMethods_a5Hs + __baseRequest_a5Ht + __complianceClasses_a5Hv + __httpManager_a5Hw + __lockToken_a5Hx + __basicusername_a5Hy + __basicpassword_a5Hz + __depth_a5HA) + Data.Functor.<$> (_f_a5Hr __complianceClasses'_a5Hu)) +{-# INLINE complianceClasses #-} +depth :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) (Maybe Depth) +depth + _f_a5HB + (DAVContext __allowedMethods_a5HC + __baseRequest_a5HD + __complianceClasses_a5HE + __httpManager_a5HF + __lockToken_a5HG + __basicusername_a5HH + __basicpassword_a5HI + __depth'_a5HJ) + = ((\ __depth_a5HK + -> DAVContext + __allowedMethods_a5HC + __baseRequest_a5HD + __complianceClasses_a5HE + __httpManager_a5HF + __lockToken_a5HG + __basicusername_a5HH + __basicpassword_a5HI + __depth_a5HK) + Data.Functor.<$> (_f_a5HB __depth'_a5HJ)) +{-# INLINE depth #-} +httpManager :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) Manager +httpManager + _f_a5HL + (DAVContext __allowedMethods_a5HM + __baseRequest_a5HN + __complianceClasses_a5HO + __httpManager'_a5HP + __lockToken_a5HR + __basicusername_a5HS + __basicpassword_a5HT + __depth_a5HU) + = ((\ __httpManager_a5HQ + -> DAVContext + __allowedMethods_a5HM + __baseRequest_a5HN + __complianceClasses_a5HO + __httpManager_a5HQ + __lockToken_a5HR + __basicusername_a5HS + __basicpassword_a5HT + __depth_a5HU) + Data.Functor.<$> (_f_a5HL __httpManager'_a5HP)) +{-# INLINE httpManager #-} +lockToken :: + Control.Lens.Type.Lens' (DAVContext a_a4I4) (Maybe B.ByteString) +lockToken + _f_a5HV + (DAVContext __allowedMethods_a5HW + __baseRequest_a5HX + __complianceClasses_a5HY + __httpManager_a5HZ + __lockToken'_a5I0 + __basicusername_a5I2 + __basicpassword_a5I3 + __depth_a5I4) + = ((\ __lockToken_a5I1 + -> DAVContext + __allowedMethods_a5HW + __baseRequest_a5HX + __complianceClasses_a5HY + __httpManager_a5HZ + __lockToken_a5I1 + __basicusername_a5I2 + __basicpassword_a5I3 + __depth_a5I4) + Data.Functor.<$> (_f_a5HV __lockToken'_a5I0)) +{-# INLINE lockToken #-}