Carlo Hamalainen


Yesod 1.1 to 1.4 notes

2015-08-16

This blog runs on a barebones blogging framework that I knocked together using Yesod 1.1 back in 2013. I recently ported it over to Yesod 1.4. Apart from the few changes that I have detailed below, everything worked straight away. Refactoring code in Haskell is a very different experience compared to fully dynamic languages.

Here are some notes on the changes that I encountered between Yesod 1.1 and 1.4. Perhaps these will be useful for someone.

aformM

Previously I used aformM to get the current time in a form:

commentForm :: EntryId -> Form Comment
commentForm entryId = renderDivs $ Comment
    <$> pure entryId
    <*> aformM (liftIO getCurrentTime)
    <*> areq textField (fieldSettingsLabel MsgCommentName) Nothing
    <*> aopt emailField (fieldSettingsLabel MsgCommentEmail) Nothing
    <*> aopt urlField (fieldSettingsLabel MsgCommentUrl) Nothing
    <*> areq htmlField (fieldSettingsLabel MsgCommentText) Nothing
    <*> pure False <* recaptchaAForm

Now, use lift (liftIO getCurrentTime):

commentForm :: EntryId -> Form Comment
commentForm entryId = renderDivs $ Comment
    <$> pure entryId
    -- <*> aformM (liftIO getCurrentTime)
    <*> lift (liftIO getCurrentTime)
    <*> areq textField (fieldSettingsLabel MsgCommentName) Nothing
    <*> aopt emailField (fieldSettingsLabel MsgCommentEmail) Nothing
    <*> aopt urlField (fieldSettingsLabel MsgCommentUrl) Nothing
    <*> areq htmlField (fieldSettingsLabel MsgCommentText) Nothing
    <*> pure False <* recaptchaAForm

MinLen

Some new names clash with the Prelude, e.g. maximum is not the usual function from the Prelude, but rather something from Data.MinLen that encodes type-level natural numbers.

*Main> :t maximum
maximum :: MonoFoldableOrd mono => MinLen (Succ nat) mono -> Element mono

*Main> :t P.maximum 
P.maximum :: Ord a => [a] -> a

No unKey or PersistInt64

Persistent values in the old system looked like this:

Entity {entityKey = Key {unKey = PersistInt64 1},
        entityVal = title: "first post" mashed title: "first-post" year: 2015 month: 8 day: 14 content: "Hi there!" visible: False}

Entity {entityKey = Key {unKey = PersistInt64 2},
        entityVal = title: "second post" mashed title: "second-post" year: 2015 month: 8 day: 14 content: "Hi there! Do de dah!" visible: False}

and we could use PersistInt64 to construct the value, or unKey to deconstruct it.

*Main> :t PersistInt64
PersistInt64 :: GHC.Int.Int64 -> PersistValue

*Main> :t unKey
unKey :: KeyBackend backend entity -> PersistValue

Now values look like:

Entity {entityKey = EntryKey {unEntryKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = "first post"}
Entity {entityKey = EntryKey {unEntryKey = SqlBackendKey {unSqlBackendKey = 2}}, entityVal = "second post"}

Old code like

foo :: PersistValue -> GHC.Int.Int64
foo (PersistInt64 i) = i

niceEntryId :: KeyBackend backend entity -> String
niceEntryId x = show $ foo $ unKey x

becomes

niceEntryId :: Key Entry -> Text
niceEntryId = DT.pack . show . unSqlBackendKey . unEntryKey

We could also use toPathPiece:

*Main> :t toPathPiece :: Key Entry -> Text
toPathPiece :: Key Entry -> Text :: Key Entry -> Text

If you're wondering how to find such a thing, look at the output of :info Key in ghci which includes these lines:

instance PathPiece (Key User) -- Defined at Model.hs:10:1
instance PathPiece (Key Entry) -- Defined at Model.hs:10:1
instance PathPiece (Key Comment) -- Defined at Model.hs:10:1

I believe that the more general option is fromSqlKey:

unKey' :: ToBackendKey SqlBackend record => Key record -> Text
unKey' = DT.pack . show . fromSqlKey

This should work over any SQL backend, unlike the older code that was tied to the particular implementation (e.g. 64bit ints).

Similarly, old code constructed a Key from an integer:

let entryId = Key $ PersistInt64 (fromIntegral i)

New code uses toSqlKey since the PersistInt64 constructor isn't available:

let entryId = toSqlKey i :: Key Entry

Links

Original blog framework, written with Yesod 1.1.9.4: https://github.com/carlohamalainen/cli-yesod-blog.

New blog framework, compiles against Yesod 1.4: https://github.com/carlohamalainen/cli-yesod-blog-1.4.

Yesod 1.4 cabal sandbox

2015-08-06

Bokeh slider for "Phenology of two interdependent traits in migratory birds in response to climate change"

2015-07-31

A while I ago I made a slider using ipywidgets that could be embedded in a html page (handy for blog posts). This week I decided to see where things were at with IPython or Jupyter.

As of July 2015 the ipywidgets package is unsupported. The author recommends using IPython's built-in interactive tools. However IPython doesn't have static widgets yet, according to this issue. A StackOverflow answer mentioned Bokeh so I decided to give that a go.

Bokeh slider

Here is a slider that replicates my earlier ipywidgets effort:

This is pretty nice. It's an interactive slider, works on desktop and mobile, and doesn't have any of the notebook stuff around it. Just the graph with the interactive widget. Bokeh also provides tools for zooming and panning around. It's also worth mentioning that Bokeh provides a GUI library (things like hboxes, vboxes, layouts, etc) and my impression is that you could have multiple plots changing based on one slider, two plots tied together on some parameter, or whatever else you dreamt up.

The slider is implemented in bokehslider.py and is run using bokeh-server --ip 0.0.0.0 --script bokehslider.py. One strange thing that I ran into was that the slider wasn't interactive unless I opened up port 5006 on my server, even though Nginx is doing the proxy_pass stuff. I suspect that some of the Bokeh-generated Javascript expects to be able to connect to the host on 5006.

Here's the relevant Nginx config settings:

server {

    # listen, root, other top level config...

    # Reverse proxy for Bokeh server running on port 5006:

    location /bokeh {
        proxy_pass http://104.200.25.78:5006/bokeh;
    }

    location /static {
        proxy_pass http://104.200.25.78:5006;
    }

    location /bokehjs {
        proxy_pass http://104.200.25.78:5006;
    }

    # rest of the config...

}

In terms of coding, the Bokeh model is a bit different to the usual plotting procedure in that you set up data sources, e.g.

obj.line_source  = ColumnDataSource(data=dict(
                                            x_cV=[],
                                            arrival_date=[],
                                            laying_date=[],
                                            hatching_date=[],))

and then plot commands use that data source. You don't pass NumPy arrays in directly:

plot = figure(plot_height=400, plot_width=400,
              tools=toolset, x_range=[130, 180], y_range=[110, 180])

plot.line('x_cV', 'x_cV',          source=obj.line_source, line_width=4, color='black')
plot.line('x_cV', 'arrival_date',  source=obj.line_source, line_width=4, color='purple', legend='Arrival time')
plot.line('x_cV', 'laying_date',   source=obj.line_source, line_width=4, color='red',    legend='Laying time')
plot.line('x_cV', 'hatching_date', source=obj.line_source, line_width=4, color='green',  legend='Hatching date')

Then, the input_change method calls my update_data method which actually updates the data sources. It doesn't have to explicitly make a call to redraw the plot.

def update_data(self):
    u_q = self.u_q_slider.value

    self.line_source.data  = get_line_data_for_bokeh(float(u_q))

Links

https://github.com/carlohamalainen/phenology-two-trait-migratory-bird/tree/bokeh-slider

http://bokeh.pydata.org/en/latest/docs/server_gallery/sliders_server.html

https://www.reddit.com/r/IPython/comments/3bgg7t/ipython_widgets_in_a_static_html_file

https://github.com/ipython/ipywidgets/issues/16

http://stackoverflow.com/questions/22739592/how-to-embed-an-interactive-matplotlib-plot-in-a-webpage

https://jakevdp.github.io/blog/2013/12/05/static-interactive-widgets

Classy mtl

2015-07-20

This post has a minimal stand-alone example of the classy lenses and prisms from George Wilson’s talk about mtl. The source code for George’s talk is here: https://github.com/gwils/next-level-mtl-with-classy-optics.

Literate Haskell source for this post is here: https://github.com/carlohamalainen/playground/tree/master/haskell/classy-mtl.

First, some imports:

> {-# LANGUAGE OverloadedStrings    #-}
> {-# LANGUAGE TemplateHaskell      #-}
> 
> module Classy where
> 
> import Control.Lens
> import Control.Monad.Except
> import Control.Monad.Reader
> import Data.Text

Toy program - uses the network and a database

The case study in George’s talk was a program that has to interact with a database and the network. We have a type for the database connection info:

> type DbConnection = Text
> type DbSchema     = Text
> 
> data DbConfig = DbConfig
>     { _dbConn :: DbConnection
>     , _schema :: DbSchema
>     }

For the network we have a port and some kind of SSL setting:

> type Port = Integer
> type Ssl  = Text
> 
> data NetworkConfig = NetworkConfig
>     { _port     :: Port
>     , _ssl      :: Ssl
>     }

At the top level, our application has a database and a network configuration:

> data AppConfig = AppConfig
>     { _appDbConfig   :: DbConfig
>     , _appNetConfig  :: NetworkConfig
>     }

Types for errors that we see when dealing with the database and the network:

> data DbError = QueryError Text | InvalidConnection
> 
> data NetworkError = Timeout Int | ServerOnFire
> 
> data AppError = AppDbError  { dbError  :: DbError      }
>               | AppNetError { netError :: NetworkError }

Classy lenses and prisms

Use Template Haskell to make all of the classy lenses and prisms. Documentation for makeClassy and makeClassyPrisms is in Control.Lens.TH.

> makeClassy ''DbConfig
> makeClassy ''NetworkConfig
> makeClassy ''AppConfig
> 
> makeClassyPrisms ''DbError
> makeClassyPrisms ''NetworkError
> makeClassyPrisms ''AppError

We get the following typeclasses:

  • HasDbConfig
  • HasNetworkConfig
  • HasAppConfig
  • AsNetworkError
  • AsDbError
  • AsAppError

For example, here is the generated class HasDbConfig:

*Classy> :i HasDbConfig
class HasDbConfig c_a6IY where
  dbConfig :: Functor f => (DbConfig -> f DbConfig) -> c0 -> f c0
  dbConn   :: Functor f => (DbConnection -> f DbConnection) -> c0 -> f c0
  schema   :: Functor f => (DbSchema -> f DbSchema) -> c0 -> f c0
instance HasDbConfig DbConfig -- Defined at Classy.lhs:58:3

If we write HasDbConfig r in the class constraints of a type signature then we can use the lenses dbConfig, dbConn, and schema to get the entire config, connection string, and schema, from something of type r.

In contrast, the constraint AsNetworkError r means that we can use the prisms _NetworkError, _Timeout, and _ServerOnFire on a value of type r to get at the network error details.

*Classy> :i AsNetworkError
class AsNetworkError r_a759 where
  _NetworkError ::
    (Choice p, Control.Applicative.Applicative f) =>
    p NetworkError (f NetworkError) -> p r0 (f r0)

  _Timeout ::
    (Choice p, Control.Applicative.Applicative f) =>
    p Int (f Int) -> p r0 (f r0)

  _ServerOnFire ::
    (Choice p, Control.Applicative.Applicative f) =>
    p () (f ()) -> p r0 (f r0)
    -- Defined at Classy.lhs:63:3

instance AsNetworkError NetworkError -- Defined at Classy.lhs:63:3

Using the class constraints

The first function is loadFromDb which uses a reader environment for database configuration, can throw a database error, and do IO actions.

> loadFromDb :: ( MonadError e m,
>                 MonadReader r m,
>                 AsDbError e,
>                 HasDbConfig r,
>                 MonadIO m) => m Text
> loadFromDb = do
> 
>   -- Due to "MonadReader r m" and "HasDbConfig r"
>   -- we can ask for the database config:
>   rdr <- ask
>   let dbconf  = rdr ^. dbConfig :: DbConfig
> 
>   -- We can ask for the connection string directly:
>   let connstr  = rdr ^. dbConn :: DbConnection
> 
>   -- We have "AsDbError e", so we can throw a DB error:
>   throwError $ (_InvalidConnection #) ()
>   throwError $ (_QueryError #) "Bad SQL!"
> 
>   return "foo"

Another function, sendOverNet uses a reader environment with a network config, throws network errors, and does IO actions.

> sendOverNet :: ( MonadError e m,
>                  MonadReader r m,
>                  AsNetworkError e,
>                  AsAppError e,
>                  HasNetworkConfig r,
>                  MonadIO m) => Text -> m ()
> sendOverNet mydata = do
> 
>   -- We have "MonadReader r m" and "HasNetworkConfig r"
>   -- so we can ask about the network config:
>   rdr <- ask
>   let netconf = rdr ^. networkConfig  :: NetworkConfig
>       p       = rdr ^. port           :: Port
>       s       = rdr ^. ssl            :: Ssl
> 
>   liftIO $ putStrLn $ "Pretending to connect to the network..."
> 
>   -- We have "AsNetworkError e" so we can throw a network error:
>   throwError $ (_NetworkError #) (Timeout 100)
> 
>   -- We have "AsAppError e" so we can throw an application-level error:
>   throwError $ (_AppNetError #) (Timeout 100)
> 
>   return ()

If we load from the database and also send over the network then we get extra class constraints:

> loadAndSend :: ( AsAppError e,
>                  AsNetworkError e,
>                  AsDbError e,
>                  HasNetworkConfig r,
>                  HasDbConfig r,
>                  MonadReader r m,
>                  MonadError e m,
>                  MonadIO m) => m ()
> loadAndSend = do
>   liftIO $ putStrLn "Loading from the database..."
>   t <- loadFromDb
> 
>   liftIO $ putStrLn "Sending to the network..."
>   sendOverNet t

Things that won’t compile

We can’t throw the database error InvalidConnection without the right class constraint:

> nope1 :: (MonadError e m, AsNetworkError e) => m ()
> nope1 = throwError $ (_InvalidConnection #) ()
Could not deduce (AsDbError e)
arising from a use of ‘_InvalidConnection’

We can’t throw an application error if we are only allowed to throw network errors, even though this specific application error is a network error:

> nope2 :: (MonadError e m, AsNetworkError e) => m ()
> nope2 = throwError $ (_AppNetError #) (Timeout 100)
Could not deduce (AsAppError e)
arising from a use of ‘_AppNetError’

We can’t get the network config from a value of type r if we only have the constraint about having the database config:

> nope3 :: (MonadReader r m, HasDbConfig r) => m ()
> nope3 = do
>   rdr <- ask
>   let netconf = rdr ^. networkConfig
> 
>   return ()
Could not deduce (HasNetworkConfig r)
arising from a use of ‘networkConfig’

What is the #?

The # is an infix alias for review. More details are in Control.Lens.Review.

*Classy> :t review _InvalidConnection ()
review _InvalidConnection () :: AsDbError e => e

*Classy> :t throwError $ review _InvalidConnection ()
throwError $ review _InvalidConnection () :: (AsDbError e, MonadError e m) => m a

What is the monad transformer stack?

We didn’t specify it! The functions loadFromDb and sendOverNet have the general monad m in their type signatures, not a specific transformer stack like ReaderT AppConfig (ExceptT AppError IO) a.

What else?

Ben Kolera did a talk at BFPG about stacking monad transformers. He later modified the code from his talk to use the classy lens/prism approach. You can see the code before and after, and also see a diff. As far as I could see there is one spot in the code where an error is thrown, which motivated me to create the stand-alone example in this post with the body for loadFromDb and sendOverNet sketched out.

Lens Has/As for API changes

2015-06-30

Tinkering with lenses to deal with API changes.

Literate Haskell source for this post: https://github.com/carlohamalainen/playground/tree/master/haskell/lens-has.

First, some extensions and imports.

> {-# LANGUAGE GADTs                        #-}
> {-# LANGUAGE FlexibleInstances            #-}
> {-# LANGUAGE MultiParamTypeClasses        #-}
> {-# LANGUAGE TemplateHaskell              #-}
> module LensHas where
> import Control.Applicative
> import Control.Lens
> import Numeric.Natural

Introduction

Suppose we are working with a database service that stores files. Perhaps we communicate with it via a REST API. A file stored in the system has a location, which is a FilePath:

> type Location = FilePath

We need to keep track of a few other things like the parent (referring to a collection of files) and a hash of the file. For simplicity I’ll make those two fields Strings since the details aren’t important to us here.

> data DataFile = DataFile {
>     _dataFileLocation :: Location
>   , _dataFileParent   :: String
>   , _dataFileHash     :: String
> } deriving Show

(Ignore the underscores if you haven’t used lenses before.)

After some time the API changes and we need to keep track of some different fields, so our data type changes to:

> data DataFile2 = DataFile2 {
>     _dataFile2Location   :: Location
>   , _dataFile2Parent     :: String
>   , _dataFile2OtherField :: Float -- new field
>                                   -- hash is not here anymore
> } deriving Show

For compatibility we’d like to keep both definitions around, perhaps allowing the user to choose the v1 or v2 API with a configuration option. So how do we deal with our code that has to use DataFile or DataFile2? One option is to use a sum type:

> data DataFileSum = DFS1 DataFile | DFS2 DataFile2

Any function that uses a DataFile must instead use DataFileSum and do case analysis on whether it is a v1 or v2.

In my particular situation I had a number of functions that used just the Location part of the type. Is there a way to avoid the sum type?

Setter/Getter typeclasses

Use typeclasses to represent setting or getting the location value:

> class SetLocation a where
>   setLocation :: a -> Location -> a
> class GetLocation a where
>   getLocation :: a -> Location

Write the instance definitions for each case:

> instance SetLocation DataFile where
>   setLocation d newLocation = d { _dataFileLocation = newLocation }
> 
> instance GetLocation DataFile where
>   getLocation = _dataFileLocation
> instance SetLocation DataFile2 where
>   setLocation d newLocation = d { _dataFile2Location = newLocation }
> 
> instance GetLocation DataFile2 where
>   getLocation = _dataFile2Location

Now we use the general getLocation and setLocation functions instead of the specific data constructors of DataFile and DataFile2:

> main1 = do
>   let df = DataFile "/foo/bar.txt" "something" "700321159acb26a5fd6d5ce0116a6215"
> 
>   putStrLn $ "Original data file: " ++ show df
>   putStrLn $ "Location in original: " ++ getLocation df
> 
>   let df' = setLocation df "/blah/bar.txt"
> 
>   putStrLn $ "Updated data file:    " ++ getLocation df'

A function that uses a datafile can now be agnostic about which one it is, as long as the typeclass constraint is satisfied so that it has the appropriate getter/setter:

> doSomething :: GetLocation a => a -> IO ()
> doSomething d = print $ getLocation d

Using doSomething:

*LensHas> doSomething $ DataFile "/foo/bar.txt" "parent" "12345"
"/foo/bar.txt"

*LensHas> doSomething $ DataFile2 "/foo/bar.txt" "parent" 42.2
"/foo/bar.txt"

Lenses

Lenses already deal with the concept of getters and setters, so let’s try to replicate the previous code in that framework.

First, make lenses for the two data types (this uses Template Haskell):

> makeLenses ''DataFile
> makeLenses ''DataFile2

Instead of type classes for setting and getting, make a single type class that represents the fact that a thing has a location.

> class HasLocation a where
>     location :: Lens' a Location

For the instance definitions we can use the lenses that were automatically made for us by the earlier makeLenses lines:

> instance HasLocation DataFile where
>     location = dataFileLocation :: Lens' DataFile Location
> 
> instance HasLocation DataFile2 where
>     location = dataFile2Location :: Lens' DataFile2 Location

Here is main1 rewritten to use the location lens:

> main2 = do
>   let df = DataFile "/foo/bar.txt" "something" "700321159acb26a5fd6d5ce0116a6215"
> 
>   putStrLn $ "Original data file: " ++ show df
>   putStrLn $ "Location in original: " ++ df^.location
> 
>   let df' = df & location .~ "/blah/bar.txt"
> 
>   putStrLn $ "Updated data file:    " ++ getLocation df'

If you haven’t used lenses before the operators like ^. might look insane, but there is a pattern to them. Check out http://intolerable.me/lens-operators-intro for an excellent guide with examples.

One benefit of the lens approach is that we don’t have to manually write the setters and getters, as they come for free from the lenses for the original two data types. Another benefit is that lenses compose, so if the Location type was more than just a string, we wouldn’t have to manually deal with the composition of getLocation with getSubPartOfLocation and so on.

The doSomething function can be rewritten using the HasLocation typeclass:

> doSomething' :: HasLocation a => a -> IO ()
> doSomething' d = print $ d^.location

Generalising HasLocation

Let’s generalise the HasLocation typeclass. Consider natural numbers (the Natural type).

First case: here’s a typeclass to represent the fact that a Foo can always be thought of as a Natural:

> class AsNatural1 a where
>     nat1 :: Lens' a Natural
> data Foo = Foo {
>   _fooName :: String
> , _fooNat  :: Natural
> } deriving Show
> 
> makeLenses ''Foo
> instance AsNatural1 Foo where
>   nat1 = fooNat :: Lens' Foo Natural

Second case: a natural is a natural by definition.

> instance AsNatural1 Natural where
>   nat1 = id

Third case: an Integer might be a Natural. The previous typeclasses used a Lens’ but here we need a Prism’:

> class AsNatural2 a where
>     nat2 :: Prism' a Natural
> instance AsNatural2 Integer where
>   nat2 = prism' toInteger (\n -> if n >= 0 then (Just . fromInteger) n else Nothing)

We are doing much the same thing, and if we compare the two typeclasses the difference is in the type of “optical” thing being used (a lens or a prism):

> class AsNatural1 a where
>     nat1 :: Lens' a Natural
> 
> class AsNatural2 a where
>     nat2 :: Prism' a Natural

It turns out that the type to use is Optic’:

> class AsNatural p f s where
>   natural :: Optic' p f s Natural

(We get the extra parameters p and f which seem to be unavoidable.)

Now we can do all of the previous definitions using the single typeclass:

> -- Lens into Foo:
> 
> instance (p ~ (->), Functor f) => AsNatural p f Foo where
>   natural = fooNat :: Lens' Foo Natural
> 
> -- Natural is a Natural:
> 
> instance AsNatural p f Natural where
>   natural = id
> 
> -- An Integer might be a natural:
> 
> instance (Choice p, Applicative f) => AsNatural p f Integer where
>   natural = prism' toInteger (\n -> if n >= 0 then (Just . fromInteger) n else Nothing)

Now we can work with a Foo, a Natural, or an Integer as a Natural by using the single optical natural:

> main3 :: IO ()
> main3 = do
>   -- Underlying thing is a Lens:
>   print $ (Foo "name" 34) ^. natural
>   print $ (Foo "name" 34) ^. natural + 1
>   print $ (42 :: Natural) ^. natural + 1
> 
>   -- Underlying thing is a Prism (hence the applicative form):
>   print $ (+1) <$> ((50 :: Integer)  ^? natural)
>   print $ (+1) <$> ((-99 :: Integer) ^? natural)

Output:

*LensHas> main3
34
35
43
Just 51
Nothing

Credit

The AsNatural type is a simplified version of the “As…” typeclasses in the coordinate package, e.g. AsMinutes. Thanks to Tony Morris on #haskell.au for helping with my changing-API question and pointing out the “As…” typeclasses. Also see the IRC logs in coordinate/etc where Ed Kmett explains some things about Optic.

Update Github fork

2015-06-29

Situation:

Repo on Github that I want to contribute to: https://github.com/whoever/whatever.git

My fork of that repo on github: git@github.com:myself/whatever.git

Over time the upstream repo is updated but my fork on github does not automatically get those updates. To push the latest changes from https://github.com/whoever/whatever.git to git@github.com:myself/whatever.git follows these steps.

Clone our repository:

git clone git@github.com:myself/whatever.git
cd whatever

Add the upstream repo as a remote, and call it upstream:

git remote add upstream https://github.com/whoever/whatever.git

Get all the branches of the upstream repo into remote-tracking branches. These branches will be named upstream/master, upstream/some-feature, etc.

git fetch upstream

Now replay all of the upstream's commits from the master branch against ours:

git checkout master
git rebase upstream/master
git push

Credit: http://stackoverflow.com/a/7244456

DCMTK: No presentation context for: (unknown SOP class) 1.3.12.2.1107.5.9.1

2015-06-03

I had a DCMTK DICOM server running with the command

storescp -p 7000 -v --fork -fe '.IMA' --sort-on-study-uid 'my_prefix'

One of our Siemens instruments couldn't push some files to the DCMTK server, so I tried to send the files manually using storescu:

parallel -j 30 storescu localhost 7000 -- `find siemens_data/ -type f`

While the Siemens instrument gave nothing of note, I found that storescu failed with:

E: No presentation context for: (unknown SOP class) 1.3.12.2.1107.5.9.1
E: Store SCU Failed: 0006:0208 DIMSE No valid Presentation Context ID

Apparently 1.3.12.2.1107.5.9.1 is a "private" Siemens SOP class. To fix things in my situation I tried adding the -pm flag so that storescp would accept unknown SOP classes:

storescp -p 7000 -v --fork -pm -fe '.IMA' --sort-on-study-uid 'my_prefix'

This fixed things so that the Siemens instrument could send data, but storescu still failed. It turned out, after reading this forum post, that storescu needs to know about the new SOP class.

I copied /etc/dcmtk/storescu.cfg and edited out the 125th presentation context definition and added the Siemens UID:

# PresentationContext125 = XRayRadiationDoseSRStorage\Uncompressed
PresentationContext125 = 1.3.12.2.1107.5.9.1\Uncompressed

There are already 128 presentation contexts in the file and you can't have more than that (some limitation in DICOM?). Now pushing files using storescu works, if we refer to the config file and the Default profile entry:

parallel -j 30 storescu -xf storescu.cfg Default localhost 7000 -- `find extract/ -type f`

The forum post that I linked to earlier has an example config file with a [PrivateSiemens] section in the [[Profiles]]. I tried this but (as far as I understand) you have to copy all of the SOP classes that you might see, and run storescu referring to the PrivateSiemens profile name. So you may as well edit out an unused presentation context in the Default configuration.

Note to self: exceptions in multithreaded Haskell

2015-05-25

Note to self on catching exceptions in multithreaded Haskell code. Literate Haskell source and build scripts and cabal stuff is at https://github.com/carlohamalainen/playground/tree/master/haskell/exceptions-in-parallel.

For my use cases there are two scenarios when running a list of worker threads:

  1. If any thread throws an exception, give up on everything.

  1. If any thread throws an exception, log it, but let the other workers run to completion.

First, imports that we’ll use:

> {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
> 
> module Main where
> 
> import Data.Conduit
> import Data.Conduit.List
> import Data.Traversable (traverse)
> import Control.Applicative
> import Control.Monad.Catch
> import Control.Concurrent
> import Control.Concurrent.Async
> import Control.Concurrent.ParallelIO.Local
> import Control.Monad hiding (mapM, mapM_)
> import Control.Monad.Catch
> import Data.Typeable
> import Prelude hiding (map, mapM, mapM_)
> import System.IO

We will use code from parallel-io and async for running worker threads. For a pipeline we’ll also use conduit.

Here’s our exception type, which we throw using throwM from Control.Monad.Catch:

> data MyException = MyException String deriving (Show, Typeable)
> 
> instance Exception MyException

Our two tasks. The first task immediately throws an exception; the second waits for 5 seconds and completes happily.

> task1 :: IO String
> task1 = throwM $ MyException "task1 blew up"
> 
> task2 :: IO String
> task2 = do
>   threadDelay $ 5 * 10^6
>   return $ "task2 finished"

Example: parallel_

> main1 :: IO ()
> main1 = do
> 
>   x <- withPool 2 $ \pool -> parallel_ pool [task1, task2]
>   print (x :: ())

Output:

*Main> main1
*** Exception: MyException "task1 blew up"

Example: parallelE_

> main2 :: IO ()
> main2 = do
> 
>   x <- withPool 2 $ \pool -> parallelE_ pool [task1, task2]
>   print x

Output:

*Main> main2
[Just (MyException "task1 blew up"),Nothing]

Example: parallel

> main3 :: IO ()
> main3 = do
>   x <- withPool 2 $ \pool -> parallel pool [task1, task2]
>   print x

Output:

*Main> main3
*** Exception: MyException "task1 blew up"

Example: parallelE

> main4 :: IO ()
> main4 = do
>   x <- withPool 2 $ \pool -> parallelE pool [task1, task2]
>   print x

Output:

*Main> main4
[Left (MyException "task1 blew up"),Right "task2 finished"]

Example: async/wait

> main5 :: IO ()
> main5 = do
>   a1 <- async task1
>   a2 <- async task2
>   result1 <- wait a1
>   result2 <- wait a2
> 
>   print [result1, result2]

Output:

*Main> main5
*** Exception: MyException "task1 blew up"

Example: async/waitCatch

> main6 :: IO ()
> main6 = do
>   a1 <- async task1
>   a2 <- async task2
>   result1 <- waitCatch a1
>   result2 <- waitCatch a2
> 
>   print [result1, result2]

Output:

*Main> main6
[Left (MyException "task1 blew up"),Right "task2 finished"]

Example: concurrently

> main7 :: IO ()
> main7 = do
>   result <- concurrently task1 task2
> 
>   print result

Output:

*Main> main7
*** Exception: MyException "task1 blew up"

Example: throwM in a conduit sink

> main8 :: IO ()
> main8 = do
>   sourceList [1..5] $$ (throwM $ MyException "main8 in conduit exploded")
>   print "this is never printed"

Output:

*** Exception: MyException "main8 in conduit exploded"

Example: throwM in a conduit sink (on one value)

> main9 :: IO ()
> main9 = do
> 
>   let foo x = if x == 3 then throwM $ MyException "got a 3 in main9"
>                         else print x
> 
>   sourceList [1..5] $$ (mapM_ foo)
>   print "this is never printed"

The conduit processes values 1 and 2, throws an exception on 3, and never sees 4 and 5.

*Main> main9
1
2
*** Exception: MyException "got a 3 in main9"

Example: throwM/catchC

> main10 :: IO ()
> main10 = do
> 
>   let foo x = if x == 3 then throwM $ MyException "got a 3 in main10"
>                         else print x
> 
>   let sink = catchC (mapM_ foo)
>                     (\(e :: SomeException) -> mapM_ $ \x -> putStrLn $ "When processing " ++ show x ++ " caught exception: " ++ show e)
> 
>   sourceList [1..5] $$ sink
>   print "main10 finished"

The output is not what I expected. Values 1 and 2 are processed as expected, then the 3 throws an exception, but the effect of catchC is that the rest of the values (4 and 5) are processed using the second argument to catchC. In this situation, a conduit can’t be used to process a stream with independently failing components. You have to catch all exceptions before they bubble up to the conduit code.

1
2
When processing 4 caught exception: MyException "got a 3 in main10"
When processing 5 caught exception: MyException "got a 3 in main10"
"main10 finished"

Example: catchAll in conduit

A combinator that runs an IO action and catches any exception:

> catchBlah :: Show a => (a -> IO ()) -> a -> IO ()
> catchBlah action = \x -> catchAll (action x)
>                                   (\(e :: SomeException) -> putStrLn $ "On value " ++ show x ++ " caught exception: " ++ show e)

Using catchBlah in the sink:

> main11 :: IO ()
> main11 = do
> 
>   let foo x = if x == 3 then throwM $ MyException "got a 3 in main11"
>                         else print x
> 
>   sourceList [1..5] $$ (mapM_ $ catchBlah foo)
> 
>   print "main11 finished"

Now the conduit processes every value, because the exception is caught and dealt with at a lower level.

*Main> main11
1
2
On value 3 caught exception: MyException "got a 3 in main11"
4
5
"main11 finished"

Example: catchBlah’ in conduit

Now, suppose we have a few stages in the conduit and the first stage blows up. Use catchAll to catch the exception and return a IO (Maybe b) instead of IO b:

> catchBlah' :: Show a => (a -> IO b) -> a -> IO (Maybe b)
> catchBlah' action = \x -> do
>   catchAll (action x >>= (return . Just))
>            (\(e :: SomeException) -> do putStrLn $ "On value " ++ show x ++ " caught exception: " ++ show e
>                                         return Nothing)
> main12 :: IO ()
> main12 = do
> 
>   let src = [1..5] :: [Int]
> 
>   let stage1 x = do when (x == 3) $ throwM $ MyException "Got a 3 in stage1"
>                     putStrLn $ "First print: " ++ show x
>                     return x
> 
>   sourceList src $$ (mapM $ catchBlah' stage1) =$= (mapM_ print)
> 
>   print "main12 finished"

Output:

First print: 1
Just 1
First print: 2
Just 2
On value 3 caught exception: MyException "Got a 3 in stage1"
Nothing
First print: 4
Just 4
First print: 5
Just 5
"main12 finished"

Example: catchBlah’ in conduit (tweaked)

Same as the previous example but with nicer printing in the sink:

> main13 :: IO ()
> main13 = do
> 
>   let src = [1..5] :: [Int]
> 
>   let stage1 x = do when (x == 3) $ throwM $ MyException "Got a 3 in stage1"
>                     putStrLn $ "First print: " ++ show x
>                     return x
>       stage2 x = case x of
>                       Just x' -> do putStrLn $ "Second print: " ++ show (x' + 1)
>                                     putStrLn ""
>                       Nothing -> do putStrLn $ "Second print got Nothing..."
>                                     putStrLn ""
> 
>   sourceList src $$ (mapM $ catchBlah' stage1) =$= (mapM_ stage2)
> 
>   print "main13 finished"

Output:

*Main> main13
First print: 1
Second print: 2

First print: 2
Second print: 3

On value 3 caught exception: MyException "Got a 3 in stage1"
Second print got Nothing...

First print: 4
Second print: 5

First print: 5
Second print: 6

"main13 finished"

Posts: RSS