module Database.Blacktip
( module Database.Blacktip.Types
, generateUniqueId
, generateUniqueId'
, getInterfaceByName
, getUnixMillis
, integerToRecord
, toBase62
) where
import qualified Control.Concurrent as CC
import qualified Control.Concurrent.MVar as MV
import qualified Data.ByteString.Char8 as B
import qualified Data.Locator as DL
import qualified Data.Time.Clock.POSIX as PSX
import qualified Filesystem as FS
import qualified Filesystem.Path.CurrentOS as FPC
import qualified Network.Info as NI
import qualified Safe
import Control.Exception (mask, try)
import Control.Monad (forever, when)
import Data.Bits
import Data.Bits.Bitwise (fromListBE)
import Data.List.Split (chunksOf)
import Database.Blacktip.Types
import System.IO.Unsafe (unsafePerformIO)
getInterfaceByName :: InterfaceName -> IO (Maybe NI.NetworkInterface)
getInterfaceByName n = fmap (Safe.headMay
. filter ((n ==)
. NI.name))
NI.getNetworkInterfaces
toBase62 :: Integer -> String
toBase62 = DL.toBase62
getMac :: Interface -> IO (Maybe NI.MAC)
getMac iface = case iface of
NIInterface interf -> return $ Just (NI.mac interf)
IName name -> (fmap . fmap) NI.mac (getInterfaceByName name)
getUnixMillis :: IO Milliseconds
getUnixMillis = fmap (round . (*1000)) PSX.getPOSIXTime
serverState :: MV.MVar ServerState
serverState = unsafePerformIO $ MV.newEmptyMVar
readTimestamp :: FPC.FilePath -> IO Int
readTimestamp path = do
result <- try $ FS.readFile path :: IO (Either IOError B.ByteString)
case result of
(Right "") -> return 0
_ -> return $ either (const 0) (read . B.unpack) result
writeTimestamp :: MV.MVar ServerState -> FPC.FilePath -> IO CC.ThreadId
writeTimestamp s path = do
CC.forkIO go
where go = forever $ do
ss <- MV.readMVar s
mask $ \_ -> do
FS.writeFile path (B.pack (show (ssTime ss)))
CC.threadDelay 1000000
arrowOfTimeError :: (Show a, Show b) => a -> b -> c
arrowOfTimeError ts stateTime =
error ("ERROR ARROW OF TIME BACKWARDS - Had timestamp: "
++ show ts
++ " and state time: "
++ show stateTime)
bumpItYo :: Milliseconds -> ServerState -> ServerState
bumpItYo ts s
| ts == stateTime = s { ssSequence = (+1) stateSeq }
| ts > stateTime = s { ssTime = ts, ssSequence = 0 }
| otherwise = arrowOfTimeError ts stateTime
where stateTime = ssTime s
stateSeq = ssSequence s
generateUniqueId' :: Config -> IO (Either NoInterfaceError
(UniqueId, IdentityRecord))
generateUniqueId' config = do
millis <- getUnixMillis
empty <- MV.isEmptyMVar serverState
_ <- when empty (initWriter (timestampPath config))
mState <- MV.takeMVar serverState
let newState = bumpItYo millis mState
_ <- MV.putMVar serverState newState
let sSeq = ssSequence $ newState
mMac <- (getMac . interface) config
case mMac of
Nothing -> return $ Left NoInterfaceError
Just mac -> return $ Right ((binnify millis mac sSeq), IdentityRecord millis mac sSeq)
generateUniqueId :: Config -> IO (Either NoInterfaceError UniqueId)
generateUniqueId config = do
uid <- generateUniqueId' config
return $ fmap fst uid
initWriter :: FPC.FilePath -> IO ()
initWriter path = do
ms <- getUnixMillis
stateTime <- readTimestamp path
_ <- when (ms <= stateTime) (arrowOfTimeError ms stateTime)
_ <- MV.putMVar serverState (ServerState ms 0)
_ <- writeTimestamp serverState path
return ()
binnify :: Milliseconds -> NI.MAC -> Sequence -> Integer
binnify ms (NI.MAC a b c d e f) sq = withSq
where withTimestamp = shift (toInteger ms) 64
withMacA = shift (toInteger a) 56 .|. withTimestamp
withMacB = shift (toInteger b) 48 .|. withMacA
withMacC = shift (toInteger c) 40 .|. withMacB
withMacD = shift (toInteger d) 32 .|. withMacC
withMacE = shift (toInteger e) 24 .|. withMacD
withMacF = shift (toInteger f) 16 .|. withMacE
withSq = withMacF .|. toInteger sq
bitRange :: Bits a => a -> Int -> Int -> [Bool]
bitRange n lo hi = reverse $ map (testBit n) [lo..hi]
integerToRecord :: Integer -> IdentityRecord
integerToRecord n = IdentityRecord milliseconds mac recSequence
where extractedBits = bitRange n 0 127
milliBits = take 64 extractedBits
macBits = chunksOf 8 $ take 48 $ drop 64 extractedBits
sequenceBits = take 16 $ drop 112 extractedBits
milliseconds = fromListBE milliBits :: Milliseconds
a = fromListBE (macBits !! 0)
b = fromListBE (macBits !! 1)
c = fromListBE (macBits !! 2)
d = fromListBE (macBits !! 3)
e = fromListBE (macBits !! 4)
f = fromListBE (macBits !! 5)
mac = (NI.MAC a b c d e f)
recSequence = fromListBE sequenceBits :: Sequence