filelockをSolarisへ

Solarisにfilelockライブラリを移植する

で、何でこうなったかですが、もともとhaskellのfilelockパッケージがflock関数を内部で利用していたことが事の発端で、Solaris上でbuildするとエラーになる。

...
...
In file included from dist/build/System/FileLock/Internal/Flock_hsc_make.c:1:0:
Flock.hsc: In function 'main':
Flock.hsc:57:16: error: 'LOCK_SH' undeclared (first use in this function)
/usr/gnu/lib/ghc-7.10.3/template-hsc.h:35:10: note: in definition of macro 'hsc_const'
     if ((x) < 0)                                      \
          ^
Flock.hsc:57:16: note: each undeclared identifier is reported only once for each function it appears in
/usr/gnu/lib/ghc-7.10.3/template-hsc.h:35:10: note: in definition of macro 'hsc_const'
     if ((x) < 0)                                      \
          ^
Flock.hsc:58:16: error: 'LOCK_EX' undeclared (first use in this function)
/usr/gnu/lib/ghc-7.10.3/template-hsc.h:35:10: note: in definition of macro 'hsc_const'
     if ((x) < 0)                                      \
          ^
Flock.hsc:61:16: error: 'LOCK_NB' undeclared (first use in this function)
/usr/gnu/lib/ghc-7.10.3/template-hsc.h:35:10: note: in definition of macro 'hsc_const'
     if ((x) < 0)                                      \
          ^
...
...

いつも、忘れたころにやってくる

実際のコードを確認してみる

抜粋しますと

...
flock :: Fd -> Bool -> Bool -> IO Bool
flock (Fd fd) exclusive block = do
  r <- c_flock fd $ modeOp .|. blockOp
  if r == 0
    then return True -- success
    else do
      errno <- getErrno
      case () of
        _ | errno == eWOULDBLOCK
            -> return False -- already taken
          | errno == eINTR
            -> flock (Fd fd) exclusive block
          | otherwise -> throwErrno "flock"
  where
    modeOp = case exclusive of
      False -> #{const LOCK_SH}
      True -> #{const LOCK_EX}
    blockOp = case block of
      True -> 0
      False -> #{const LOCK_NB}
...

動作としては、modeOpで「共有ロック」か「排他ロック」を、blockOpが「LOCK_NB」フラグを追加するかどうかで、「LOCK_NB」が指定されない場合はブロックする可能性があるので「eINTR」に対応していて、その場合は再度ロックが取得できるまで繰り返し、「LOCK_NB」が指定された場合、ロックが取れなかったら素直にIO Falseを返す仕組みになっています。ここを、Solarisで動かしたいって言うことです。

Solarisで動かす

とりあえず全部のコードはgithubにあげて置きますの確認してくださいと言う事で...
https://github.com/calimakvo/filelock.git

flock構造体
Cで定義されているflock構造体をhaskell内で利用するため対応する型をdataで定義する

data CFLock = CFLock {
  l_type   :: !CInt,
  l_whence :: !CInt,
  l_start  :: !COff,
  l_len    :: !COff,
  l_pid    :: !CPid
} deriving(Eq, Ord, Show)

この定義だけでは使えませんので、Storableクラスのインスタンスに登録する、こうすることでghcがCFlock型とflock構造体を相互に変換することが可能になります。

instance Storable CFLock where
  sizeOf x = sizeOf (l_type x)
             + sizeOf (l_whence x)
             + sizeOf (l_start x)
             + sizeOf (l_len x)
             + sizeOf (l_pid x)
  alignment _ = alignment (undefined :: COff)
  peek ptr = CFLock <$> #{peek struct flock, l_type} ptr
                   <*> #{peek struct flock, l_whence} ptr
                   <*> #{peek struct flock, l_start} ptr
                   <*> #{peek struct flock, l_len} ptr
                   <*> #{peek struct flock, l_pid} ptr
  poke ptr (CFLock t w s l p) = do
      #{poke struct flock, l_type} ptr t'
      #{poke struct flock, l_whence} ptr w'
      #{poke struct flock, l_start} ptr s'
      #{poke struct flock, l_len} ptr l'
      #{poke struct flock, l_pid} ptr p'
    where
      t' = fromIntegral t :: CInt
      w' = fromIntegral w :: CInt
      s' = fromIntegral s :: COff
      l' = fromIntegral l :: COff
      p' = fromIntegral p :: CPid

flock関数を置き換える
書き換えた部分だけの抜粋ですが、「EINTR」は「blockOp = True」、「F_SETLKW」で呼んだときに受け取る可能性があるので注意するのと、「exclusive = False」の場合に「F_RDLCK」で呼ばれるので、openFd関数のOpenModeを「WriteRead」にする必要があること(処理を排他するためならちょっと微妙に感じるけど...)。

flock :: Fd -> Bool -> Bool -> IO Bool
flock (Fd fd) exclusive block = do
  flck <- new modeOp
  r <- c_fcntl fd blockOp flck
  if r /= -1
    then return True -- success
    else do
      errno <- getErrno
      case () of
        _ | (errno == Errno #{const EAGAIN} ||
             errno == Errno #{const EACCES})
            -> return False -- already taken
          |  errno == Errno #{const EINTR}
            -> flock (Fd fd) exclusive block
          | otherwise -> throwErrno $ "fcntl(" ++ show(errno) ++ ")"
  where
    modeOp = case exclusive of
      False -> CFLock #{const F_RDLCK} #{const SEEK_SET} 0 0 0
      True -> CFLock #{const F_WRLCK} #{const SEEK_SET} 0 0 0
    blockOp = case block of
      True -> #{const F_SETLKW}
      False -> #{const F_SETLK} -- #{const LOCK_NB}

foreign import ccall "fcntl.h fcntl"
  c_fcntl :: CInt -> CInt -> (Ptr CFLock) -> IO CInt

補足
fcntl関数のプロトタイプ宣言を見ると引数が可変長引数になっています。

int fcntl(int fd, int cmd, ... /* arg */ );

可変長引数をhaskellで表現するのは難しいと思ったので、第3引数がflock構造体を取得する関数に固定化して作ってあります。上手いやり方が見つかりませんでした、方法があったら教えてください。

ついでにhsc拡張子について

このコードはFFI(Foreign Function Interface)といってhaskellのコードから通常のCの関数を呼び出す仕組みになっているため、ちょっと変換が必要。
hsc2hsコマンドを使って普通のhsコードに変換できる、こんな感じ

cuomo@karky7 ~ $ hsc2hs Flock.hsc

ってやるとFlock.hsを作ってくれる、こうすると{#const LOCK_NB}とかが展開されてghciとかでloadできるようになるよ。

ちょっとまて、これがあったじゃないか

いろいろ調べて見たのですが、こういう奴もありました

Prelude> :m +System.Posix.IO
Prelude System.Posix.IO> :m +System.IO
Prelude System.Posix.IO System.IO> :m +System.Posix.Files
Prelude System.Posix.IO System.IO System.Posix.Files>:t setLock
setLock :: System.Posix.Types.Fd -> FileLock -> IO ()
Prelude System.Posix.IO System.IO System.Posix.Files> fd <- openFd "/tmp/lock" ReadWrite (Just stdFileMode) defaultFileFlags
Prelude System.Posix.IO System.IO System.Posix.Files> setLock fd (WriteLock, AbsoluteSeek, 0, 0)
Prelude System.Posix.IO System.IO System.Posix.Files>

こういうのもありです。

ただFFIでやってみたかっただけです、では