summaryrefslogtreecommitdiff
path: root/provider/posts
diff options
context:
space:
mode:
authorGregor Kleen <gkleen@yggdrasil.li>2015-08-12 14:26:40 +0200
committerGregor Kleen <gkleen@yggdrasil.li>2015-08-12 14:26:40 +0200
commit9b2333f49cf510df8a42e0b2655ecb2c55c6d56c (patch)
treedab6dc2c2e3124ccef7ce81140d48acd555888e2 /provider/posts
parenta568e0ccde5a9914512e3d3f5af850b4a652e47f (diff)
downloaddirty-haskell.org-9b2333f49cf510df8a42e0b2655ecb2c55c6d56c.tar
dirty-haskell.org-9b2333f49cf510df8a42e0b2655ecb2c55c6d56c.tar.gz
dirty-haskell.org-9b2333f49cf510df8a42e0b2655ecb2c55c6d56c.tar.bz2
dirty-haskell.org-9b2333f49cf510df8a42e0b2655ecb2c55c6d56c.tar.xz
dirty-haskell.org-9b2333f49cf510df8a42e0b2655ecb2c55c6d56c.zip
Sketch of beuteltier-4.lhs
Diffstat (limited to 'provider/posts')
-rw-r--r--provider/posts/beuteltier-4.lhs227
1 files changed, 227 insertions, 0 deletions
diff --git a/provider/posts/beuteltier-4.lhs b/provider/posts/beuteltier-4.lhs
new file mode 100644
index 0000000..11cb8bc
--- /dev/null
+++ b/provider/posts/beuteltier-4.lhs
@@ -0,0 +1,227 @@
1---
2title: Business Logic for an Overly Complicated Feedreader
3published: 2015-08-12
4tags: Beuteltier
5---
6
7It turns out I don´t have to write much in the way of comments—the source file is already
8quite well commented.
9
10> {-# LANGUAGE KindSignatures #-}
11>
12> module Beuteltier
13> ( -- * Forcing (Executing) 'Thunk's
14> forceAllThunks
15> , WithObjects
16> , forceThunk
17> , resetAllThunks
18> , resetThunk
19> -- * Higher level interactions with a 'Beutel'
20> , replace
21> , eqTo
22> , update
23> , forceAllThunks'
24> , resetAllThunks'
25> , module Beuteltier.Util
26> , module Beuteltier.Types.Common
27> ) where
28>
29> import Beuteltier.Types.Common
30> import Beuteltier.Util
31>
32> import Data.Map (Map)
33> import qualified Data.Map as Map
34>
35> import Control.Lens
36>
37> import qualified Data.ByteString.Lazy as LBS
38> import qualified Data.ByteString as BS
39>
40> import qualified Data.Text as T
41> import qualified Data.Text.IO as T
42> import qualified Data.Text.Lazy as TL
43>
44> import System.FilePath
45> import System.Directory
46> import System.Posix.Files
47> import System.Posix.Temp
48>
49> import System.Environment
50> import System.IO
51> import GHC.IO.Handle
52> import System.Process as P
53> import System.Exit
54>
55> import Control.Concurrent
56> import Control.Applicative
57> import Control.Monad.Morph
58> import Control.Monad.Trans.State
59> import Control.Monad.Writer
60> import Control.Monad.Trans.Resource
61> import Control.Monad (liftM)
62>
63> import Data.Time.Clock
64>
65> import Data.BoolExpr
66
67The distinguishing feature of our Overly Complicated Feedreader™ is it´s support for
68`Thunk`s. It is thus reasonable to expect, that we have some functions to actually
69interact with them. Most striking in that hypothetical set of functions would be one that
70executes all thunks associated with a single `ObjectGen` and return a new one with the
71content generated by `Thunk`s filled in.
72
73Enter `forceAllThunks`.
74
75> forceAllThunks :: (MonadIO f, MonadResource f)
76> => (Thunk -> Bool) -- ^ Select which 'Thunk's to force
77> -> ObjectGen f -> f (ObjectGen f)
78> -- ^ Force all thunks in place and update '_oContent'
79> --
80> -- The reason we require a 'MonadResource' instance is that we would like to store our expensive to hold in RAM 'SubObject' contents in temporary files.
81> forceAllThunks pred = flip alter $ do
82> pureThunks <- use oThunks >>= lift >>= mapM lift
83> (newThunks, objectResults) <- mapAndUnzipM forceThunk' pureThunks
84> assign oThunks $ return $ map return newThunks
85> oContent %= liftM (<> mconcat objectResults)
86> where
87> forceThunk' thunk
88> | pred thunk = forceThunk thunk
89> | otherwise = return (thunk, Map.empty)
90
91`forceAllThunks'` (`resetAllThunks'` below, too) is tainted by the evil of
92`generateObject` but included for convenience.
93
94> forceAllThunks' :: (MonadIO f, MonadResource f) => (Thunk -> Bool) -> StateT Object f ()
95> -- ^ Version of 'forceAllThunks' suitable for use with 'update'
96> forceAllThunks' pred = get >>= lift . forceAllThunks pred . liftGen >>= lift . generateObject >>= put
97>
98> -- | Internal helper to track computations creating 'SubObject's
99> type WithObjects (n :: * -> *) (m :: * -> *) = WriterT (Map SubObjectName (n SubObject)) m
100>
101> forceThunk_ :: (MonadIO m, MonadResource m) => Thunk -> WithObjects (ResourceT IO) m Thunk
102> -- ^ Make sure the 'ThunkState' contained within a 'Thunk' is 'Executed'
103> forceThunk_ = flip alter $ do
104> -- (result, subObjects) <- liftIO $ runWriterT $ parseThunk thunk
105> -- writer ((), subObjects)
106> (result, subObjects) <- listen . hoist (hoist liftResourceT) . lift . parseThunk =<< get
107> tState .= Executed (Map.keys subObjects) result
108>
109> forceThunk :: (MonadResource m, MonadResource n) => Thunk -> m (Thunk, Map SubObjectName (n SubObject))
110> -- ^ Force a 'Thunk' and return it in 'Executed' state together with the 'SubObject's it created during execution
111> forceThunk thunk = liftM (_2 %~ fmap liftResourceT) $ (runWriterT . forceThunk_) thunk
112
113Quite often we want to undue the harm done by `forceAllThunks` (to save space, usually).
114
115> resetAllThunks :: Monad f
116> => (Thunk -> Bool) -- ^ Select which 'Thunk's to reset
117> -> ObjectGen f -> f (ObjectGen f)
118> -- ^ Undoes 'forceAllThunks':
119> --
120> -- prop> forceAllThunks (const True) obj >>= resetAllThunks (const True) >>= forceAllThunks (const True) = forceAllThunks (const True) obj
121> --
122> -- This inevitably drops information ('ThunkResult's for one).
123> --
124> -- In the case where 'forceAllThunks' does not drop information (i.e.: no 'SubObjectName' collisions ocurr) the following, stronger property holds:
125> --
126> -- prop> forceAllThunks (const True) obj >>= resetAllThunks (const True) = return obj
127> resetAllThunks pred = flip alter $ do
128> thunks <- liftM (map lift) (use oThunks >>= lift) >>= sequence
129> let
130> (subObjectNames, newThunks) = over _1 concat $ unzip $ map resetThunk' thunks
131> oThunks .= return (map return newThunks)
132> oContent %= (>>= return . Map.filterWithKey (\k _ -> k `notElem` subObjectNames))
133> where
134> resetThunk' thunk
135> | pred thunk = resetThunk thunk
136> | otherwise = ([], thunk)
137>
138> resetAllThunks' :: (MonadIO f, MonadResource f) => (Thunk -> Bool) -> StateT Object f ()
139> -- ^ Version of 'resetAllThunks' suitable for use with 'update'
140> resetAllThunks' pred = get >>= lift . resetAllThunks pred . liftGen >>= lift . generateObject >>= put
141>
142> resetThunk :: Thunk -> ([SubObjectName], Thunk)
143> -- ^ Reset a thunk and return the 'SubObjectName's of the 'SubObject's it once created.
144> -- This forgets information.
145> resetThunk thunk = case thunk ^. tState of
146> NotExecuted -> ([], thunk)
147> Executed created _ -> (created, set tState NotExecuted thunk)
148>
149> parseThunk :: Thunk -> WithObjects (ResourceT IO) (ResourceT IO) ThunkResult
150> -- ^ Generate a runnable action from a 'Thunk'
151> --
152> -- Regarding the "inner" and "outer" 'Monad' here being 'IO': We have not, at time of forcing, a neccessary connection to our backstore and thus cannot expect the monads to be anything else.
153> parseThunk thunk = do
154> tmpDirName <- liftIO getTemporaryDirectory
155> progName <- liftIO getProgName
156> let
157> tmpDirName' = tmpDirName </> progName
158> (_, tmpDir) <- allocate (mkdtemp tmpDirName') removeDirectoryRecursive
159> let exec = tmpDir </> "exec"
160> out = tmpDir </> "out"
161> result <- liftIO $ do
162> createDirectory out
163> LBS.writeFile exec script
164> setFileMode exec $ foldl unionFileModes nullFileMode [ownerReadMode, ownerExecuteMode]
165> (Just std_in, Just std_out, Just std_err, ph) <- createProcess $ (P.proc exec []) { cwd = Just out, std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe }
166> hClose std_in
167> hSetBinaryMode std_out True
168> hSetBinaryMode std_err True
169> std_out `sendTo` stdout
170> std_err `sendTo` stderr
171> construct $ do
172> rOutStd <~ TL.fromStrict <$> liftIO (T.hGetContents std_out) -- Yes, sadly we have to be strict here
173> rOutErr <~ TL.fromStrict <$> liftIO (T.hGetContents std_err)
174> rExit <~ toNum <$> liftIO (waitForProcess ph)
175> outputFiles <- liftIO $ getDirectoryContents out
176> let
177> outputFiles' = filter fileFilter outputFiles
178> fileFilter = and . (<*>) [(/=) ".", (/=) ".."] . pure . takeFileName
179> mapM_ tell =<< mapM (liftResourceT . toSubObject) outputFiles'
180> return result
181> where
182> script = thunk ^. tScript
183> toSubObject :: FilePath -> ResIO (Map SubObjectName (ResIO SubObject))
184> -- ^ Using 'ResourceT' provides us with the guarantee, that the 'FilePath' we´re referring to should still exist when we actually try to get the 'SubObject'´s contents
185> toSubObject name = fmap (Map.singleton name' . return) $ construct $ do
186> sContent <~ liftIO (LBS.readFile name)
187> sUpdates <~ pure <$> liftIO getCurrentTime
188> where
189> name' = takeFileName name
190> sendTo input output = do
191> input' <- hDuplicate input
192> forkIO $ do
193> hSetBuffering input' NoBuffering
194> LBS.hGetContents input' >>= LBS.hPutStr output
195> return ()
196> toNum :: Num a => ExitCode -> a
197> toNum ExitSuccess = 0
198> toNum (ExitFailure i) = fromInteger $ toInteger i
199
200We provide quite a few convenience functions for high-level interactions.
201
202> replace :: Beutel f => Object -> f ()
203> -- ^ @replace o@ replaces /all/ 'Object's 'Equivalent' to @o@ within the 'Beutel' with @o@.
204> --
205> -- Does not handle '_sUpdates'.
206> --
207> -- Uses 'eqTo' and is thus costly.
208> replace o = delete (eqTo o) >> insert o
209>
210> eqTo :: Monad f => Object -> SearchQuery f
211> -- ^ @eqTo o@ constructs a 'SearchQuery' that matches all 'Object's 'Equivalent' to @o@
212> --
213> -- This is costly because it calls 'generateObject' on the contents of the entire 'Beutel'.
214> eqTo o = BConst ((>>= return . (~~) o) . generateObject)
215>
216> update :: Beutel f => SearchQuery f -> StateT Object f a -> f ()
217> -- ^ @update search action@ replaces /all/ 'Object's matching @search@ within the 'Beutel' by versions of themselves modified by applying @action@.
218> --
219> -- Does not handle '_sUpdates'.
220> --
221> -- This is costly because it calls 'generateObject' on the contents of the entire 'Beutel' /and/ all results of @search@ (in order to use 'Eq' on 'Object's to delete the results of the initial 'search').
222> update query alteration = do
223> matches <- search query
224> matches' <- mapM generateObject matches
225> delete $ BConst ((>>= return . (`elem` matches')) . generateObject)
226> mapM_ (\o -> alter o alteration >>= insert) matches'
227> return ()
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 16:57:17 +0000