gistfile1.hs

regenerate :: Pool Connection -> String -> String -> IO ()
regenerate pool dir subId = do
  inPool pool $ \conn -> do
    let strPair = (fromSql . head) &&& ((fromSql :: SqlValue -> String) . head . tail)
    fromDb <- filter (not . null . fst) <$> map strPair <$> 
            quickQuery' conn ("SELECT url, ext FROM f_main_playlist(?)") [toSql subId]
    dat <- catMaybes <$> mapM (\(url, ext) -> do
                                  let parsed = parseAbsoluteURI url
                                  case parsed of
                                    Just URI{uriAuthority=Just auth} -> do
                                      let host = uriRegName auth
                                      ip <- (head . hostAddresses) <$> getHostByName host
                                      syslog Notice ("auth - " ++ show host ++ "," ++ show ip ++ "," ++ show ext)
                                      return $ Just (ip, url, ext)
                                    Nothing ->
                                      return Nothing) fromDb

    newStdGen >>= setStdGen
    volId <- randomW32 
    ct <- getClockTime >>= toCalendarTime

    let fs = filesystem $ mapM_ (constructFile (gigs 2)) $ zip [1..] dat
        rsvd  = 32
        cl = CL_32K
        dSize = calcDataSize cl fs
        fat = genFileAllocTableRaw cl dSize fs
        fSize = fatSize cl dSize
        volSize = calcVolSize rsvd cl dSize
        fatInfo = FAT32GenInfo cl volSize volId "RADIO" (fatSectorsOf fSize) (Just rsvd)
        vm = compileRules $ genFATRules fatInfo fat ct fs
    syslog Notice $ "size:" ++ show dSize ++ "," ++ show volSize
    withFile (dir ++ subId) WriteMode $ \hFile -> L.hPut hFile $ toBinary vm

randomW32 :: IO Word32
randomW32 = liftM fromIntegral (randomIO :: IO Int)

constructFile size (n, (ip, url, ext)) = do
  let name = printf "%02d.%s" n ext
      firstBytes = runPut $ do
        putWord32be n
        putWord32be ip
        putLazyByteString $ LC.pack url
        putWord8 0
  file name size $ const firstBytes